From 220adbfc63e8e77d9e8732a7be6c7fa8edc25ecf Mon Sep 17 00:00:00 2001 From: George Vandenberghe Date: Thu, 1 Apr 2021 17:54:58 +0000 Subject: [PATCH 01/77] Changes to support 2D Decomposition shape changes. Full I dimension remains in all arrays bu t SURFCE is altered to use isx:iex bounds which are equivalent to IM which is equivalent to 1:IM --- sorc/ncep_post.fd/CTLBLK.f | 5 +- sorc/ncep_post.fd/MPI_FIRST.f | 21 +- sorc/ncep_post.fd/PARA_RANGE.f | 18 + sorc/ncep_post.fd/PROCESS.f | 6 + sorc/ncep_post.fd/SURFCE.f | 568 ++++++++++++++++--------------- sorc/ncep_post.fd/TIMEF.f | 19 +- sorc/ncep_post.fd/WRFPOST.f | 51 ++- sorc/ncep_post.fd/grib2_module.f | 8 + 8 files changed, 385 insertions(+), 311 deletions(-) diff --git a/sorc/ncep_post.fd/CTLBLK.f b/sorc/ncep_post.fd/CTLBLK.f index 13797bd5e..15ae026e4 100644 --- a/sorc/ncep_post.fd/CTLBLK.f +++ b/sorc/ncep_post.fd/CTLBLK.f @@ -9,6 +9,8 @@ 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 03/29 George Vandenberghe. Add isx and iex upper and lower bounds for 2D decomposition +! !----------------------------------------------------------------------- ! implicit none @@ -41,7 +43,7 @@ module CTLBLK_mod real*8 :: gdsdegr real,allocatable :: datapd(:,:,:) ! - logical :: gocart_on, d3d_on, hyb_sigp + logical :: gocart_on, d3d_on, hyb_sigp ,rdaod logical :: SIGMA,RUN,FIRST,RESTRT logical :: global logical :: SMFLAG @@ -60,6 +62,7 @@ module CTLBLK_mod MPI_COMM_COMP, IM,JM,LM,NSOIL,LP1,LM1,IM_JM, & lsm,lsmp1 !comm mpi ! + integer isx, iex ! <<---- GWV ADD upper and lower I dimensions for 2D decomposition real :: ARDSW, ARDLW, ASRFC, TSRFC,TRDLW,TRDSW,TCLOD,THEAT, & TPREC,TMAXMIN,TD3D !comm rad ! diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 920f78e18..2243fc624 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -13,6 +13,8 @@ !! 02-06-19 MIKE BALDWIN - WRF VERSION !! 11-12-16 SARAH LU - MODIFIED TO INITIALIZE AEROSOL FIELDS !! 12-01-07 SARAH LU - MODIFIED TO INITIALIZE AIR DENSITY/LAYER THICKNESS +!! 3/28/2021 George Vandenberghe. Added isx and iex variables to +!! determine lower and upper bounds for a 2D decomposition !! !! USAGE: CALL MPI_FIRST !! INPUT ARGUMENT LIST: @@ -85,8 +87,8 @@ SUBROUTINE MPI_FIRST() use ctlblk_mod, only: me, num_procs, jm, jsta, jend, jsta_m, jsta_m2, & jend_m, jend_m2, iup, idn, icnt, im, idsp, jsta_2l, jend_2u, & jvend_2u, lm, lp1, jsta_2l, jend_2u, nsoil, nbin_du, nbin_ss, & - nbin_bc, nbin_oc, nbin_su - + nbin_bc, nbin_oc, nbin_su, & + isx,iex ! ! use params_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -116,7 +118,13 @@ SUBROUTINE MPI_FIRST() ! ! global loop ranges ! - call para_range(1,jm,num_procs,me,jsta,jend) +! Using J dimension and number of ranks obtain beginning and end J +! limits for each rank. +! 2d also obtain beginning and end I limits for each rank (using +! para_range2) +! +!gwv call para_range(1,jm,num_procs,me,jsta,jend) + call para_range2(1,jm,1,im,num_procs,me,jsta,jend,isx,iex) jsta_m = jsta jsta_m2 = jsta jend_m = jend @@ -149,7 +157,8 @@ SUBROUTINE MPI_FIRST() ! counts, disps for gatherv and scatterv ! do i = 0, num_procs - 1 - call para_range(1,jm,num_procs,i,jsx,jex) + call para_range2(1,jm,1,im,num_procs,i,jsx,jex,isx,iex) +!gwv delete after 2D support is validated 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 @@ -172,8 +181,8 @@ SUBROUTINE MPI_FIRST() ! ! FROM VRBLS3D ! - print *, ' me, jsta_2l, jend_2u = ',me,jsta_2l, jend_2u, & + print *, 'GWVX me, jsta_2l, jend_2u = ',me,jsta_2l, jend_2u, & 'jvend_2u=',jvend_2u,'im=',im,'jm=',jm,'lm=',lm, & - 'lp1=',lp1 + 'lp1=',lp1,' isx and iex= ',isx,iex end diff --git a/sorc/ncep_post.fd/PARA_RANGE.f b/sorc/ncep_post.fd/PARA_RANGE.f index 404e0a41d..9aea0a070 100644 --- a/sorc/ncep_post.fd/PARA_RANGE.f +++ b/sorc/ncep_post.fd/PARA_RANGE.f @@ -46,4 +46,22 @@ SUBROUTINE PARA_RANGE (N1,N2,NPROCS,IRANK,ISTA,IEND) if ( iwork2 > irank ) iend = iend + 1 return end + SUBROUTINE PARA_RANGE2 (N1,N2,i1,i2,NPROCS,IRANK,ISTA,IEND,isx,iex) + + implicit none + integer,intent(in) :: n1,n2,nprocs,irank,i1,i2 + integer,intent(out) :: ista,iend,isx,iex + integer iwork1, iwork2 + + iwork1 = ( n2 - n1 + 1 ) / nprocs + iwork2 = mod ( n2 - n1 + 1, nprocs ) + ista = irank * iwork1 + n1 + min ( irank, iwork2 ) + iend = ista + iwork1 - 1 + if ( iwork2 > irank ) iend = iend + 1 + isx=i1 + iex=i2 + print 101,' GWVX para_range2 irank,iwork1,iwork2,ista,iend,i1,i2,isx,iex',irank,iwork1,iwork2,ista,iend,i1,i2,isx,iex + 101 format( a70,11i8) + return + end diff --git a/sorc/ncep_post.fd/PROCESS.f b/sorc/ncep_post.fd/PROCESS.f index 568678c01..dfbf39471 100644 --- a/sorc/ncep_post.fd/PROCESS.f +++ b/sorc/ncep_post.fd/PROCESS.f @@ -53,6 +53,7 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! !---------------------------------------------------------------------------- ! + use IFCORE use CTLBLK_mod, only: cfld, etafld2_tim, eta2p_tim, mdl2sigma_tim, surfce2_tim,& cldrad_tim, miscln_tim, fixed_tim, ntlfld, me !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -68,6 +69,8 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) real(kind=8) :: timef,btim CHARACTER*6 DATSET,PROJ LOGICAL NORTH + integer ifirstt + data ifirstt/0/ ! ! !**************************************************************************** @@ -77,6 +80,7 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! ! COMPUTE/POST FIELDS ON MDL SURFACES. ! +! if(ifirstt .eq. 0 .and. me .eq. 0) call tracebackqq(' GWVX FROM PROCESS',-1) btim = timef() CALL MDLFLD ETAFLD2_tim = ETAFLD2_tim +(timef() - btim) @@ -134,6 +138,8 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! NTLFLD=cfld if(me==0)print *,'nTLFLD=',NTLFLD + if(me==0)print 101,'GWVX TIMESP ', ETAFLD2_tim , ETA2P_tim , MDL2SIGMA_tim,SURFCE2_tim,CLDRAD_tim, MISCLN_tim,FIXED_tim + 101 format(a30,10f15.2) ! RETURN END diff --git a/sorc/ncep_post.fd/SURFCE.f b/sorc/ncep_post.fd/SURFCE.f index 85945fd94..d53d25b50 100644 --- a/sorc/ncep_post.fd/SURFCE.f +++ b/sorc/ncep_post.fd/SURFCE.f @@ -36,6 +36,9 @@ !! - 20-03-25 J MENG - remove grib1 !! - 20-05-20 J MENG - CALRH unification with NAM scheme !! - 20-11-10 J MENG - USE UPP_PHYSICS MODULE +!! 03/26/20 George Vandenberghe. Added support for 2D +!! decomposition in I as well as J. Changed array allocaton ranges and +!! loop boundaries !! !! USAGE: CALL SURFCE !! INPUT ARGUMENT LIST: @@ -98,7 +101,7 @@ SUBROUTINE SURFCE modelname, tmaxmin, pthresh, dtq2, dt, nphs, & ifhr, prec_acc_dt, sdat, ihrst, jsta_2l, jend_2u,& lp1, imp_physics, me, asrfc, tsrfc, pt, pdtop, & - mpi_comm_comp, im, jm, prec_acc_dt1 + mpi_comm_comp, im, jm, prec_acc_dt1,isx,iex use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml use upp_physics, only: fpvsnew, CALRH !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -121,7 +124,8 @@ SUBROUTINE SURFCE ! ! DECLARE VARIABLES. ! - integer, dimension(im,jsta:jend) :: nroots, iwx1 +!gwvx integer, dimension(im,jsta:jend) :: nroots, iwx1 + integer, dimension(isx:iex,jsta:jend) :: nroots, iwx1 real, allocatable, dimension(:,:) :: zsfc, psfc, tsfc, qsfc, & rhsfc, thsfc, dwpsfc, p1d, & t1d, q1d, zwet, & @@ -129,10 +133,10 @@ SUBROUTINE SURFCE domip, domzr, rsmin, smcref,& rcq, rct, rcsoil, gc, rcs - real, dimension(im,jsta:jend) :: evp - real, dimension(im,jsta_2l:jend_2u) :: egrid1, egrid2 + real, dimension(isx:iex,jsta:jend) :: evp + real, dimension(isx:iex,jsta_2l:jend_2u) :: egrid1, egrid2 real, dimension(im,jm) :: grid1, grid2 - real, dimension(im,jsta_2l:jend_2u) :: iceg + real, dimension(isx:iex,jsta_2l:jend_2u) :: iceg ! , ua, va real, allocatable, dimension(:,:,:) :: sleet, rain, freezr, snow ! real, dimension(im,jm,nalg) :: sleet, rain, freezr, snow @@ -166,11 +170,11 @@ SUBROUTINE SURFCE (IGET(154)>0).OR. & (IGET(034)>0).OR.(IGET(076)>0) ) THEN ! - allocate(zsfc(im,jsta:jend), psfc(im,jsta:jend), tsfc(im,jsta:jend)& - ,rhsfc(im,jsta:jend), thsfc(im,jsta:jend), qsfc(im,jsta:jend)) + allocate(zsfc(isx:iex,jsta:jend), psfc(isx:iex,jsta:jend), tsfc(isx:iex,jsta:jend)& + ,rhsfc(isx:iex,jsta:jend), thsfc(isx:iex,jsta:jend), qsfc(isx:iex,jsta:jend)) !$omp parallel do private(i,j,tsfck,qsat) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! ! SCALE ARRAY FIS BY GI TO GET SURFACE HEIGHT. ! ZSFC(I,J)=FIS(I,J)*GI @@ -239,7 +243,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = PSFC(i,jj) enddo enddo @@ -255,7 +259,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = ZSFC(i,jj) enddo enddo @@ -272,7 +276,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = TSFC(i,jj) enddo enddo @@ -288,7 +292,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = THSFC(i,jj) enddo enddo @@ -305,7 +309,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = QSFC(i,jj) enddo enddo @@ -323,7 +327,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = DWPSFC(i,jj) enddo enddo @@ -340,7 +344,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = RHSFC(i,jj) enddo enddo @@ -360,7 +364,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = QVG(i,jj) enddo enddo @@ -376,7 +380,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = QV2M(i,jj) enddo enddo @@ -391,7 +395,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = TSNOW(i,jj) enddo enddo @@ -406,7 +410,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = SNFDEN(i,jj) enddo enddo @@ -444,7 +448,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = SNDEPAC(i,jj) enddo enddo @@ -470,7 +474,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = STC(i,jj,l) enddo enddo @@ -490,7 +494,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = STC(i,jj,l) enddo enddo @@ -511,7 +515,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = SMC(i,jj,l) enddo enddo @@ -529,7 +533,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = SMC(i,jj,l) enddo enddo @@ -548,7 +552,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = SH2O(i,jj,l) enddo enddo @@ -566,7 +570,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = SH2O(i,jj,l) enddo enddo @@ -586,7 +590,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = TG(i,jj) enddo enddo @@ -598,7 +602,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = TG(i,jj) enddo enddo @@ -609,7 +613,7 @@ SUBROUTINE SURFCE IF (IGET(171)>0) THEN !!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF(SMSTAV(I,J) /= SPVAL)THEN GRID1(I,J) = SMSTAV(I,J)*100. ELSE @@ -623,7 +627,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -634,7 +638,7 @@ SUBROUTINE SURFCE IF (IGET(036)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex 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 @@ -652,7 +656,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -664,7 +668,7 @@ SUBROUTINE SURFCE IF(MODELNAME == 'RAPR') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF(CMC(I,J) /= SPVAL) then GRID1(I,J) = CMC(I,J) else @@ -675,7 +679,7 @@ SUBROUTINE SURFCE else !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF(CMC(I,J) /= SPVAL) then GRID1(I,J) = CMC(I,J)*1000. else @@ -690,7 +694,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -706,7 +710,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = SNO(i,jj) enddo enddo @@ -718,7 +722,7 @@ SUBROUTINE SURFCE ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! 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) @@ -757,7 +761,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -783,7 +787,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = PSFCAVG(i,jj) enddo enddo @@ -812,7 +816,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = T10AVG(i,jj) enddo enddo @@ -823,7 +827,7 @@ SUBROUTINE SURFCE IF ( IGET(244)>0 ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = SNONC(I,J) ENDDO ENDDO @@ -860,7 +864,7 @@ SUBROUTINE SURFCE IF ( IGET(120)>0 ) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! GRID1(I,J)=PCTSNO(I,J) IF ( SNO(I,J) /= SPVAL ) THEN SNEQV = SNO(I,J) @@ -878,7 +882,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -891,7 +895,7 @@ SUBROUTINE SURFCE ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex 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 @@ -903,7 +907,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -917,7 +921,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = POTEVP(i,jj) enddo enddo @@ -931,7 +935,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = DZICE(i,jj) enddo enddo @@ -957,7 +961,7 @@ SUBROUTINE SURFCE allocate(smcdry(im,jsta:jend), & smcmax(im,jsta:jend)) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! ---------------------------------------------------------------------- ! IF(QWBS(I,J)>0.001)print*,'NONZERO QWBS',i,j,QWBS(I,J) ! IF(abs(SM(I,J)-0.)<1.0E-5)THEN @@ -986,7 +990,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = ECAN(i,jj) enddo enddo @@ -1000,7 +1004,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = EDIR(i,jj) enddo enddo @@ -1030,7 +1034,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = SMCDRY(i,jj) enddo enddo @@ -1044,7 +1048,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = SMCMAX(i,jj) enddo enddo @@ -1068,7 +1072,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = acond(i,jj) enddo enddo @@ -1106,7 +1110,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = avgECAN(i,jj) enddo enddo @@ -1144,7 +1148,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = avgEDIR(i,jj) enddo enddo @@ -1234,7 +1238,7 @@ SUBROUTINE SURFCE !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=isx,iex 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) @@ -1251,7 +1255,7 @@ SUBROUTINE SURFCE IF (IGET(106)>0) THEN ! GRID1=spval DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! 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 @@ -1273,7 +1277,7 @@ SUBROUTINE SURFCE IF (IGET(546)>0) THEN ! GRID1=spval ! DO J=JSTA,JEND -! DO I=1,IM +! do i=isx,iex ! GRID1(I,J)=TSHLTR(I,J) ! ENDDO ! ENDDO @@ -1287,7 +1291,7 @@ SUBROUTINE SURFCE ! SHELTER LEVEL SPECIFIC HUMIDITY. IF (IGET(112)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = QSHLTR(I,J) ENDDO ENDDO @@ -1302,7 +1306,7 @@ SUBROUTINE SURFCE ! SHELTER MIXING RATIO. IF (IGET(414)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = MRSHLTR(I,J) ENDDO ENDDO @@ -1318,7 +1322,7 @@ SUBROUTINE SURFCE IF ((IGET(113)>0) .OR.(IGET(547)>0).OR.(IGET(548)>0)) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex !tgs The next 4 lines are GSD algorithm for Dew Point computation !tgs Results are very close to dew point computed in DEWPOINT subroutine @@ -1343,7 +1347,7 @@ SUBROUTINE SURFCE GRID1=spval if(MODELNAME=='RAPR')THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! 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) @@ -1351,7 +1355,7 @@ SUBROUTINE SURFCE ENDDO else DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex if(qshltr(i,j)/=spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1368,7 +1372,7 @@ 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=isx,iex EVP(I,J)=P1D(I,J)*QVl1(I,J)/(EPS+ONEPS*QVl1(I,J)) EVP(I,J)=EVP(I,J)*D001 ENDDO @@ -1377,7 +1381,7 @@ SUBROUTINE SURFCE ! print *,' MAX DEWPOINT at level 1',maxval(egrid1) GRID1=spval DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex !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 @@ -1393,7 +1397,7 @@ SUBROUTINE SURFCE ! IF ((IGET(547)>0).OR.(IGET(548)>0)) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! DEWPOINT DEPRESSION in GRID1 GRID1(i,j)=max(0.,TSHLTR(I,J)*(PSHLTR(I,J)*1.E-5)**CAPA-EGRID1(i,j)) @@ -1432,7 +1436,7 @@ SUBROUTINE SURFCE allocate(q1d(im,jsta:jend)) !$omp parallel do private(i,j,llmh) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF(MODELNAME=='RAPR')THEN LLMH = NINT(LMH(I,J)) ! P1D(I,J)=PINT(I,J,LLMH+1) @@ -1451,7 +1455,7 @@ SUBROUTINE SURFCE if (allocated(q1d)) deallocate(q1d) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex if(qshltr(i,j) /= spval)then GRID1(I,J) = EGRID1(I,J)*100. else @@ -1467,7 +1471,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1477,7 +1481,7 @@ SUBROUTINE SURFCE IF(IGET(808)>0)THEN !$omp parallel do private(i,j,dum1,dum2,dum3,dum216,dum1s,dum3s) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex DUM1 = (T1D(I,J)-TFRZ)*1.8+32. DUM2 = SQRT(U10H(I,J)**2.0+V10H(I,J)**2.0)/0.44704 DUM3 = EGRID1(I,J) * 100.0 @@ -1514,7 +1518,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1530,7 +1534,7 @@ SUBROUTINE SURFCE ! SHELTER LEVEL PRESSURE. IF (IGET(138)>0) THEN ! DO J=JSTA,JEND -! DO I=1,IM +! do i=isx,iex ! GRID1(I,J)=PSHLTR(I,J) ! ENDDO ! ENDDO @@ -1540,7 +1544,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = PSHLTR(i,jj) enddo enddo @@ -1552,7 +1556,7 @@ SUBROUTINE SURFCE ! SHELTER LEVEL MAX TEMPERATURE. IF (IGET(345)>0) THEN ! DO J=JSTA,JEND -! DO I=1,IM +! do i=isx,iex ! GRID1(I,J)=MAXTSHLTR(I,J) ! ENDDO ! ENDDO @@ -1589,7 +1593,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = MAXTSHLTR(i,jj) enddo enddo @@ -1600,7 +1604,7 @@ SUBROUTINE SURFCE IF (IGET(346)>0) THEN !!$omp parallel do private(i,j) ! DO J=JSTA,JEND -! DO I=1,IM +! do i=isx,iex ! GRID1(I,J) = MINTSHLTR(I,J) ! ENDDO ! ENDDO @@ -1635,7 +1639,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = MINTSHLTR(i,jj) enddo enddo @@ -1645,7 +1649,7 @@ SUBROUTINE SURFCE ! SHELTER LEVEL MAX RH. IF (IGET(347)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=MAXRHSHLTR(I,J)*100. ENDDO ENDDO @@ -1686,7 +1690,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1696,7 +1700,7 @@ SUBROUTINE SURFCE ! SHELTER LEVEL MIN RH. IF (IGET(348)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=MINRHSHLTR(I,J)*100. ENDDO ENDDO @@ -1735,7 +1739,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1775,7 +1779,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = maxqshltr(i,jj) enddo enddo @@ -1814,7 +1818,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = minqshltr(i,jj) enddo enddo @@ -1825,7 +1829,7 @@ SUBROUTINE SURFCE ! IF (IGET(739)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = (1./RD)*(PMID(I,J,LM)/T(I,J,LM))*SMOKE(I,J,LM,1) ENDDO ENDDO @@ -1845,7 +1849,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=isx,iex GRID1(I,J) = U10(I,J) GRID2(I,J) = V10(I,J) ENDDO @@ -1856,7 +1860,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1865,7 +1869,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1875,7 +1879,7 @@ SUBROUTINE SURFCE IF (IGET(730)>0) THEN IFINCR = 5 DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=SPDUV10MEAN(I,J) ENDDO ENDDO @@ -1899,7 +1903,7 @@ SUBROUTINE SURFCE IF (IGET(731)>0) THEN IFINCR = 5 DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=U10MEAN(I,J) ENDDO ENDDO @@ -1921,7 +1925,7 @@ SUBROUTINE SURFCE IF (IGET(732)>0) THEN IFINCR = 5 DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=V10MEAN(I,J) ENDDO ENDDO @@ -1943,7 +1947,7 @@ SUBROUTINE SURFCE IF (IGET(733)>0 )THEN IFINCR = 15 DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = SWRADMEAN(I,J) ENDDO ENDDO @@ -1965,7 +1969,7 @@ SUBROUTINE SURFCE IF (IGET(734)>0 )THEN IFINCR = 15 DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = SWNORMMEAN(I,J) ENDDO ENDDO @@ -1995,7 +1999,7 @@ SUBROUTINE SURFCE ENDIF !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = U10MAX(I,J) GRID2(I,J) = V10MAX(I,J) ENDDO @@ -2008,7 +2012,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2019,7 +2023,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2033,7 +2037,7 @@ SUBROUTINE SURFCE IF (IGET(158)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=TH10(I,J) ENDDO ENDDO @@ -2043,7 +2047,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2055,7 +2059,7 @@ SUBROUTINE SURFCE IF (IGET(505)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=T10M(I,J) ENDDO ENDDO @@ -2065,7 +2069,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2077,7 +2081,7 @@ SUBROUTINE SURFCE IF (IGET(159)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = Q10(I,J) ENDDO ENDDO @@ -2087,7 +2091,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2101,7 +2105,7 @@ SUBROUTINE SURFCE IF (IGET(422)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = WSPD10MAX(I,J) ENDDO ENDDO @@ -2117,7 +2121,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2129,7 +2133,7 @@ SUBROUTINE SURFCE IF (IGET(783)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = WSPD10UMAX(I,J) ENDDO ENDDO @@ -2145,7 +2149,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2157,7 +2161,7 @@ SUBROUTINE SURFCE IF (IGET(784)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = WSPD10VMAX(I,J) ENDDO ENDDO @@ -2173,7 +2177,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2191,7 +2195,7 @@ SUBROUTINE SURFCE CALL CALVESSEL(ICEG(1,jsta)) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = ICEG(I,J) ENDDO ENDDO @@ -2209,7 +2213,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2236,7 +2240,7 @@ SUBROUTINE SURFCE IF (IGET(172)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF (PREC(I,J) <= PTHRESH .OR. SR(I,J)==spval) THEN GRID1(I,J) = -50. ELSE @@ -2250,7 +2254,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2264,7 +2268,7 @@ SUBROUTINE SURFCE ! RDTPHS=1000./(TRDLW*3600.) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = CPRATE(I,J)*RDTPHS ! GRID1(I,J) = CUPPT(I,J)*RDTPHS ENDDO @@ -2275,7 +2279,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2289,7 +2293,7 @@ SUBROUTINE SURFCE !MEB need to get physics DT !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF(MODELNAME /= 'RSM') THEN GRID1(I,J) = PREC(I,J)*RDTPHS*1000. ELSE !Add by Binbin @@ -2303,7 +2307,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2314,7 +2318,7 @@ SUBROUTINE SURFCE IF (IGET(508)>0) THEN !-- PRATE_MAX in units of mm/h from NMMB history files DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=PRATE_MAX(I,J)*SEC2HR ENDDO ENDDO @@ -2331,7 +2335,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2342,7 +2346,7 @@ SUBROUTINE SURFCE IF (IGET(509)>0) THEN !-- FPRATE_MAX in units of mm/h from NMMB history files DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=FPRATE_MAX(I,J)*SEC2HR ENDDO ENDDO @@ -2359,7 +2363,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2393,7 +2397,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex if(AVGCPRATE(I,J)/=spval) GRID1(I,J) = AVGCPRATE(I,J)*RDTPHS ENDDO ENDDO @@ -2415,7 +2419,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2450,7 +2454,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex if(avgprec(i,j)/=spval) GRID1(I,J) = AVGPREC(I,J)*RDTPHS ENDDO ENDDO @@ -2469,7 +2473,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2501,7 +2505,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=isx,iex IF(AVGPREC(I,J) < SPVAL)THEN GRID1(I,J) = AVGPREC(I,J)*FLOAT(ID(19)-ID(18))*3600.*1000./DTQ2 ELSE @@ -2511,7 +2515,7 @@ SUBROUTINE SURFCE ENDDO !! Chuang 3/29/2018: add continuous bucket ! DO J=JSTA,JEND -! DO I=1,IM +! do i=isx,iex ! IF(AVGPREC_CONT(I,J) < SPVAL)THEN ! GRID2(I,J) = AVGPREC_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ! ELSE @@ -2522,7 +2526,7 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = ACPREC(I,J)*1000. ENDDO ENDDO @@ -2543,7 +2547,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2556,7 +2560,7 @@ SUBROUTINE SURFCE ! print*,'tinvstat in cont bucket= ',fld_info(cfld)%tinvstat ! do j=1,jend-jsta+1 ! jj = jsta+j-1 -! do i=1,im +! do i=isx,iex ! datapd(i,j,cfld) = GRID2(i,jj) ! enddo ! enddo @@ -2591,7 +2595,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=isx,iex IF(AVGPREC_CONT(I,J) < SPVAL)THEN GRID2(I,J) = AVGPREC_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ELSE @@ -2612,7 +2616,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2646,7 +2650,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=isx,iex IF(AVGCPRATE(I,J) < SPVAL)THEN GRID1(I,J) = AVGCPRATE(I,J)* & FLOAT(ID(19)-ID(18))*3600.*1000./DTQ2 @@ -2657,7 +2661,7 @@ SUBROUTINE SURFCE ENDDO !! Chuang 3/29/2018: add continuous bucket ! DO J=JSTA,JEND -! DO I=1,IM +! do i=isx,iex ! IF(AVGCPRATE_CONT(I,J) < SPVAL)THEN ! GRID2(I,J) = AVGCPRATE_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ! ELSE @@ -2668,7 +2672,7 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = CUPREC(I,J)*1000. ENDDO ENDDO @@ -2682,7 +2686,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2694,7 +2698,7 @@ SUBROUTINE SURFCE ! fld_info(cfld)%tinvstat=IFHR ! do j=1,jend-jsta+1 ! jj = jsta+j-1 -! do i=1,im +! do i=isx,iex ! datapd(i,j,cfld) = GRID2(i,jj) ! enddo ! enddo @@ -2729,7 +2733,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=isx,iex IF(AVGCPRATE_CONT(I,J) < SPVAL)THEN GRID2(I,J) = AVGCPRATE_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ELSE @@ -2749,7 +2753,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2784,7 +2788,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=isx,iex 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 @@ -2795,7 +2799,7 @@ SUBROUTINE SURFCE ENDDO !! Chuang 3/29/2018: add continuous bucket ! DO J=JSTA,JEND -! DO I=1,IM +! do i=isx,iex ! 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 @@ -2807,7 +2811,7 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = ANCPRC(I,J)*1000. ENDDO ENDDO @@ -2821,7 +2825,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2833,7 +2837,7 @@ SUBROUTINE SURFCE ! fld_info(cfld)%tinvstat=IFHR ! do j=1,jend-jsta+1 ! jj = jsta+j-1 -! do i=1,im +! do i=isx,iex ! datapd(i,j,cfld) = GRID2(i,jj) ! enddo ! enddo @@ -2868,7 +2872,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=isx,iex 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 @@ -2889,7 +2893,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2901,7 +2905,7 @@ SUBROUTINE SURFCE IF (IGET(256)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF(LSPA(I,J)<=-1.0E-6)THEN GRID1(I,J) = ACPREC(I,J)*1000 ELSE @@ -2939,7 +2943,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2950,7 +2954,7 @@ SUBROUTINE SURFCE IF (IGET(035)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! GRID1(I,J) = ACSNOW(I,J)*1000. GRID1(I,J) = ACSNOW(I,J) ENDDO @@ -2984,7 +2988,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2995,7 +2999,7 @@ SUBROUTINE SURFCE IF (IGET(746)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = ACGRAUP(I,J) ENDDO ENDDO @@ -3028,7 +3032,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3039,7 +3043,7 @@ SUBROUTINE SURFCE IF (IGET(782)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = ACFRAIN(I,J) ENDDO ENDDO @@ -3072,7 +3076,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3083,7 +3087,7 @@ SUBROUTINE SURFCE IF (IGET(121)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! GRID1(I,J) = ACSNOM(I,J)*1000. GRID1(I,J) = ACSNOM(I,J) ENDDO @@ -3117,7 +3121,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3128,7 +3132,7 @@ SUBROUTINE SURFCE IF (IGET(405)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = SNOWFALL(I,J) ENDDO ENDDO @@ -3162,7 +3166,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3173,7 +3177,7 @@ SUBROUTINE SURFCE IF (IGET(122)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! GRID1(I,J) = SSROFF(I,J)*1000. GRID1(I,J) = SSROFF(I,J) ENDDO @@ -3215,7 +3219,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3226,7 +3230,7 @@ SUBROUTINE SURFCE IF (IGET(123)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! GRID1(I,J) = BGROFF(I,J)*1000. GRID1(I,J) = BGROFF(I,J) ENDDO @@ -3268,7 +3272,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3279,7 +3283,7 @@ SUBROUTINE SURFCE IF (IGET(343)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = RUNOFF(I,J) ENDDO ENDDO @@ -3315,7 +3319,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3327,7 +3331,7 @@ SUBROUTINE SURFCE IF (IGET(434)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF (IFHR == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3377,7 +3381,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3389,7 +3393,7 @@ SUBROUTINE SURFCE IF (IGET(435)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF (IFHR == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3444,7 +3448,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3455,7 +3459,7 @@ SUBROUTINE SURFCE IF (IGET(436)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF (IFHR == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3505,7 +3509,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3516,7 +3520,7 @@ SUBROUTINE SURFCE IF (IGET(437)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = SNOW_BUCKET(I,J) ENDDO ENDDO @@ -3563,7 +3567,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3574,7 +3578,7 @@ SUBROUTINE SURFCE IF (IGET(775)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = GRAUP_BUCKET(I,J) ENDDO ENDDO @@ -3621,7 +3625,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3634,7 +3638,7 @@ SUBROUTINE SURFCE IF (IGET(526)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3657,7 +3661,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3667,7 +3671,7 @@ SUBROUTINE SURFCE IF (IGET(527)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3690,7 +3694,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3700,7 +3704,7 @@ SUBROUTINE SURFCE IF (IGET(528)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3723,7 +3727,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3733,7 +3737,7 @@ SUBROUTINE SURFCE IF (IGET(529)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3757,7 +3761,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3767,7 +3771,7 @@ SUBROUTINE SURFCE IF (IGET(530)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3791,7 +3795,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3812,7 +3816,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=isx,iex IWX = IWX1(I,J) SNOW(I,J,1) = MOD(IWX,2) SLEET(I,J,1) = MOD(IWX,4)/2 @@ -3825,7 +3829,7 @@ SUBROUTINE SURFCE ! LOWEST WET BULB ZERO HEIGHT IF (IGET(247)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = ZWET(I,J) ENDDO ENDDO @@ -3835,7 +3839,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3856,7 +3860,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IWX = IWX1(I,J) SNOW(I,J,2) = MOD(IWX,2) SLEET(I,J,2) = MOD(IWX,4)/2 @@ -3879,7 +3883,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IWX = IWX1(I,J) SNOW(I,J,3) = MOD(IWX,2) SLEET(I,J,3) = MOD(IWX,4)/2 @@ -3895,7 +3899,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IWX = IWX1(I,J) SNOW(I,J,4) = MOD(IWX,2) SLEET(I,J,4) = MOD(IWX,4)/2 @@ -3911,7 +3915,7 @@ SUBROUTINE SURFCE else !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IWX1(I,J) = 0 ENDDO ENDDO @@ -3921,7 +3925,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IWX = IWX1(I,J) SNOW(I,J,5) = MOD(IWX,2) SLEET(I,J,5) = MOD(IWX,4)/2 @@ -3939,7 +3943,7 @@ SUBROUTINE SURFCE grid1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex if(prec(i,j) /= spval) GRID1(I,J) = DOMS(I,J) ENDDO ENDDO @@ -3949,7 +3953,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3958,7 +3962,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex if(prec(i,j)/=spval) GRID1(I,J) = DOMIP(I,J) ENDDO ENDDO @@ -3968,7 +3972,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3977,7 +3981,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! if (DOMZR(I,J) == 1) THEN ! PSFC(I,J)=PINT(I,J,NINT(LMH(I,J))+1) ! print *, 'aha ', I, J, PSFC(I,J) @@ -3993,7 +3997,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4002,7 +4006,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex if(prec(i,j)/=spval)GRID1(I,J) = DOMR(I,J) ENDDO ENDDO @@ -4012,7 +4016,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4035,7 +4039,7 @@ SUBROUTINE SURFCE ! print *,'in SURFCE,me=',me,'IWX1=',IWX1(1:30,JSTA) !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IWX = IWX1(I,J) SNOW(I,J,1) = MOD(IWX,2) SLEET(I,J,1) = MOD(IWX,4)/2 @@ -4057,7 +4061,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IWX = IWX1(I,J) SNOW(I,J,2) = MOD(IWX,2) SLEET(I,J,2) = MOD(IWX,4)/2 @@ -4080,7 +4084,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IWX = IWX1(I,J) SNOW(I,J,3) = MOD(IWX,2) SLEET(I,J,3) = MOD(IWX,4)/2 @@ -4097,7 +4101,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IWX = IWX1(I,J) SNOW(I,J,4) = MOD(IWX,2) SLEET(I,J,4) = MOD(IWX,4)/2 @@ -4114,7 +4118,7 @@ SUBROUTINE SURFCE else !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IWX1(I,J) = 0 ENDDO ENDDO @@ -4124,7 +4128,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IWX = IWX1(I,J) SNOW(I,J,5) = MOD(IWX,2) SLEET(I,J,5) = MOD(IWX,4)/2 @@ -4174,7 +4178,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex if(avgprec(i,j) /= spval) GRID1(I,J) = DOMS(I,J) ENDDO ENDDO @@ -4192,7 +4196,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4221,7 +4225,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex if(avgprec(i,j)/=spval) GRID1(I,J) = DOMIP(I,J) ENDDO ENDDO @@ -4238,7 +4242,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4268,7 +4272,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! if (DOMZR(I,J) == 1) THEN ! PSFC(I,J)=PINT(I,J,NINT(LMH(I,J))+1) ! print *, 'aha ', I, J, PSFC(I,J) @@ -4291,7 +4295,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4322,7 +4326,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex if(avgprec(i,j)/=spval) GRID1(I,J) = DOMR(I,J) ENDDO ENDDO @@ -4339,7 +4343,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4363,7 +4367,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex DOMS(I,J) = 0. !-- snow DOMR(I,J) = 0. !-- rain DOMZR(I,J) = 0. !-- freezing rain @@ -4372,7 +4376,7 @@ SUBROUTINE SURFCE ENDDO DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex !-- TOTPRCP is total 1-hour accumulated precipitation in [m] totprcp = (RAINC_BUCKET(I,J) + RAINNC_BUCKET(I,J))*1.e-3 snowratio = 0.0 @@ -4493,7 +4497,7 @@ SUBROUTINE SURFCE maxval(snow_bucket)*0.1,minval(snow_bucket)*0.1 DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex 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 @@ -4510,7 +4514,7 @@ SUBROUTINE SURFCE icnt_snow_rain_mixed = 0 DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex if (DOMR(i,j)==1 .and. DOMS(i,j)==1) then icnt_snow_rain_mixed = icnt_snow_rain_mixed + 1 endif @@ -4524,7 +4528,7 @@ SUBROUTINE SURFCE ! SNOW. !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=DOMS(I,J) ENDDO ENDDO @@ -4534,7 +4538,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4542,7 +4546,7 @@ SUBROUTINE SURFCE ! ICE PELLETS. !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = DOMIP(I,J) ! if (DOMIP(I,J) == 1) THEN ! print *, 'ICE PELLETS at I,J ', I, J @@ -4555,7 +4559,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4563,7 +4567,7 @@ SUBROUTINE SURFCE ! FREEZING RAIN. !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex ! 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) @@ -4577,7 +4581,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4585,7 +4589,7 @@ SUBROUTINE SURFCE ! RAIN. !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = DOMR(I,J) ENDDO ENDDO @@ -4595,7 +4599,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4625,7 +4629,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF(SFCLHX(I,J)/=SPVAL)THEN GRID1(I,J)=-1.*SFCLHX(I,J)*RRNUM !change the sign to conform with Grib ELSE @@ -4678,7 +4682,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF(SFCSHX(I,J)/=SPVAL)THEN GRID1(I,J) = -1.* SFCSHX(I,J)*RRNUM !change the sign to conform with Grib ELSE @@ -4731,7 +4735,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = SUBSHX(I,J)*RRNUM ENDDO ENDDO @@ -4780,7 +4784,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = SNOPCX(I,J)*RRNUM ENDDO ENDDO @@ -4829,7 +4833,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF(SFCUVX(I,J)/=SPVAL)THEN GRID1(I,J) = SFCUVX(I,J)*RRNUM ELSE @@ -4882,7 +4886,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = SFCUX(I,J)*RRNUM ENDDO ENDDO @@ -4931,7 +4935,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = SFCVX(I,J)*RRNUM ENDDO ENDDO @@ -4970,7 +4974,7 @@ SUBROUTINE SURFCE ! ACCUMULATED SURFACE EVAPORATION IF (IGET(047)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = SFCEVP(I,J)*1000. ENDDO ENDDO @@ -5012,7 +5016,7 @@ SUBROUTINE SURFCE ! ACCUMULATED POTENTIAL EVAPORATION IF (IGET(137)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = POTEVP(I,J)*1000. ENDDO ENDDO @@ -5053,7 +5057,7 @@ SUBROUTINE SURFCE ! ROUGHNESS LENGTH. IF (IGET(044)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = Z0(I,J) ENDDO ENDDO @@ -5067,7 +5071,7 @@ SUBROUTINE SURFCE ! FRICTION VELOCITY. IF (IGET(045)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = USTAR(I,J) ENDDO ENDDO @@ -5084,7 +5088,7 @@ SUBROUTINE SURFCE GRID1=spval CALL CALDRG(EGRID1(1,jsta_2l)) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex IF(USTAR(I,J) < spval) GRID1(I,J)=EGRID1(I,J) ENDDO ENDDO @@ -5097,7 +5101,7 @@ SUBROUTINE SURFCE write_cd: IF(IGET(922)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=CD10(I,J) ENDDO ENDDO @@ -5109,7 +5113,7 @@ SUBROUTINE SURFCE ENDIF write_cd write_ch: IF(IGET(923)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=CH10(I,J) ENDDO ENDDO @@ -5126,7 +5130,7 @@ SUBROUTINE SURFCE ! MODEL OUTPUT SURFACE U COMPONENT WIND STRESS. IF (IGET(900)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=MDLTAUX(I,J) ENDDO ENDDO @@ -5141,7 +5145,7 @@ SUBROUTINE SURFCE ! MODEL OUTPUT SURFACE V COMPONENT WIND STRESS IF (IGET(901)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=MDLTAUY(I,J) ENDDO ENDDO @@ -5163,7 +5167,7 @@ SUBROUTINE SURFCE ! dong for FV3, directly use model output IF (IGET(133)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=EGRID1(I,J) IF(MODELNAME == 'FV3R') THEN GRID1(I,J)=SFCUXI(I,J) @@ -5181,7 +5185,7 @@ SUBROUTINE SURFCE ! SURFACE V COMPONENT WIND STRESS IF (IGET(134)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=EGRID2(I,J) IF(MODELNAME == 'FV3R') THEN GRID1(I,J)=SFCVXI(I,J) @@ -5202,7 +5206,7 @@ SUBROUTINE SURFCE ! GRAVITY U COMPONENT WIND STRESS. IF (IGET(315)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = GTAUX(I,J) ENDDO ENDDO @@ -5240,7 +5244,7 @@ SUBROUTINE SURFCE ! SURFACE V COMPONENT WIND STRESS IF (IGET(316)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=GTAUY(I,J) ENDDO ENDDO @@ -5284,14 +5288,14 @@ SUBROUTINE SURFCE MODELNAME=='RAPR')THEN !4omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex 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=isx,iex IF(TWBS(I,J) < spval) GRID1(I,J) = -TWBS(I,J) ENDDO ENDDO @@ -5311,14 +5315,14 @@ SUBROUTINE SURFCE MODELNAME=='RAPR')THEN !4omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex 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=isx,iex IF(QWBS(I,J) < spval) GRID1(I,J) = -QWBS(I,J) ENDDO ENDDO @@ -5333,7 +5337,7 @@ SUBROUTINE SURFCE ! SURFACE EXCHANGE COEFF IF (IGET(169)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=SFCEXC(I,J) ENDDO ENDDO @@ -5347,7 +5351,7 @@ SUBROUTINE SURFCE ! GREEN VEG FRACTION IF (IGET(170)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=VEGFRC(I,J)*100. ENDDO ENDDO @@ -5362,7 +5366,7 @@ SUBROUTINE SURFCE ! MIN GREEN VEG FRACTION IF (IGET(726)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=shdmin(I,J)*100. ENDDO ENDDO @@ -5376,7 +5380,7 @@ SUBROUTINE SURFCE ! MAX GREEN VEG FRACTION IF (IGET(729)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=shdmax(I,J)*100. ENDDO ENDDO @@ -5393,7 +5397,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=isx,iex IF (MODELNAME=='RAPR')THEN GRID1(I,J)=LAI(I,J) ELSE @@ -5413,7 +5417,7 @@ SUBROUTINE SURFCE ! INSTANTANEOUS GROUND HEAT FLUX IF (IGET(152)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=GRNFLX(I,J) ENDDO ENDDO @@ -5426,7 +5430,7 @@ SUBROUTINE SURFCE ! VEGETATION TYPE IF (IGET(218)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = FLOAT(IVGTYP(I,J)) ENDDO ENDDO @@ -5440,7 +5444,7 @@ SUBROUTINE SURFCE ! SOIL TYPE IF (IGET(219)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = FLOAT(ISLTYP(I,J)) ENDDO ENDDO @@ -5453,7 +5457,7 @@ SUBROUTINE SURFCE ! SLOPE TYPE IF (IGET(223)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = FLOAT(ISLOPE(I,J)) ENDDO ENDDO @@ -5479,7 +5483,7 @@ SUBROUTINE SURFCE 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)) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex 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 @@ -5522,7 +5526,7 @@ SUBROUTINE SURFCE IF (IGET(220)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = GC(I,J) ENDDO ENDDO @@ -5535,7 +5539,7 @@ SUBROUTINE SURFCE IF (IGET(234)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = RSMIN(I,J) ENDDO ENDDO @@ -5548,7 +5552,7 @@ SUBROUTINE SURFCE IF (IGET(235)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = FLOAT(NROOTS(I,J)) ENDDO ENDDO @@ -5561,7 +5565,7 @@ SUBROUTINE SURFCE IF (IGET(236)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = SMCWLT(I,J) ENDDO ENDDO @@ -5574,7 +5578,7 @@ SUBROUTINE SURFCE IF (IGET(237)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = SMCREF(I,J) ENDDO ENDDO @@ -5587,7 +5591,7 @@ SUBROUTINE SURFCE IF (IGET(238)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = RCS(I,J) ENDDO ENDDO @@ -5600,7 +5604,7 @@ SUBROUTINE SURFCE IF (IGET(239)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = RCT(I,J) ENDDO ENDDO @@ -5613,7 +5617,7 @@ SUBROUTINE SURFCE IF (IGET(240)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = RCQ(I,J) ENDDO ENDDO @@ -5626,7 +5630,7 @@ SUBROUTINE SURFCE IF (IGET(241)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = RCSOIL(I,J) ENDDO ENDDO @@ -5655,7 +5659,7 @@ SUBROUTINE SURFCE IF(IGET(236)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = smcwlt(i,j) ! IF(isltyp(i,j)/=0)THEN ! GRID1(I,J) = WLTSMC(isltyp(i,j)) @@ -5670,7 +5674,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5680,7 +5684,7 @@ SUBROUTINE SURFCE IF(IGET(397)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = fieldcapa(i,j) ! IF(isltyp(i,j)/=0)THEN ! GRID1(I,J) = REFSMC(isltyp(i,j)) @@ -5695,7 +5699,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5705,7 +5709,7 @@ SUBROUTINE SURFCE IF(IGET(396)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = suntime(i,j) ENDDO ENDDO @@ -5739,7 +5743,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5749,7 +5753,7 @@ SUBROUTINE SURFCE IF(IGET(517)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = avgpotevp(i,j) ENDDO ENDDO @@ -5783,7 +5787,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5796,7 +5800,7 @@ SUBROUTINE SURFCE IF (IGET(282)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J) = PT ENDDO ENDDO @@ -5810,7 +5814,7 @@ SUBROUTINE SURFCE ! PRESSURE THICKNESS REQUESTED BY CMAQ IF (IGET(283)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=PDTOP ENDDO ENDDO @@ -5834,7 +5838,7 @@ SUBROUTINE SURFCE ! SIGMA PRESSURE THICKNESS REQUESTED BY CMAQ IF (IGET(273)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=PD(I,J) ENDDO ENDDO @@ -5859,7 +5863,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=isx,iex GRID1(I,J)=AKHSAVG(I,J) ENDDO ENDDO @@ -5884,7 +5888,7 @@ SUBROUTINE SURFCE ! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR WIND REQUESTED FOR CMAQ IF (IGET(504)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=AKMSAVG(I,J) ENDDO ENDDO @@ -5911,7 +5915,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=isx,iex GRID1(I,J)=AKHSAVG(I,J) ENDDO ENDDO @@ -5936,7 +5940,7 @@ SUBROUTINE SURFCE ! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR WIND REQUESTED FOR CMAQ IF (IGET(504)>0) THEN DO J=JSTA,JEND - DO I=1,IM + do i=isx,iex GRID1(I,J)=AKMSAVG(I,J) ENDDO ENDDO diff --git a/sorc/ncep_post.fd/TIMEF.f b/sorc/ncep_post.fd/TIMEF.f index f380c9af6..e2cae9f44 100644 --- a/sorc/ncep_post.fd/TIMEF.f +++ b/sorc/ncep_post.fd/TIMEF.f @@ -3,17 +3,20 @@ !mp HPs) Designed to duplicate timef (elapsed time in milliseconds) ! function timef() + use mpi implicit none - real et(2) + real *8 et(2),rtc + data et/0.0,0.0/ real*8 timef, etime - timef=etime(et) - timef=timef*1.e3 + if(et(1) .eq. 0) et(1)=mpi_wtime() + et(2)=mpi_wtime() + timef=(et(2)-et(1)) +! timef=(et(2)-et(1))*1.e3 +! timef=mpi_wtime() *1.e3 -ti end - function rtc() - implicit none - real et(2) + function rtcfake() real*8 rtc, etime - rtc=etime(et) - rtc=rtc*1.e3 + rtcfake=mpi_wtime() *1.e3 +! rtcfake=rtc*1.e3 end diff --git a/sorc/ncep_post.fd/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f index ec422fb39..a1c2f8bc3 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -178,6 +178,7 @@ PROGRAM WRFPOST character startdate*19,SysDepInfo*80,IOWRFNAME*3,post_fname*255 character cgar*1,cdum*4,line*10 + real(kind=8) t1,t2,ta,tb,tc,td,te,tf,tg ! !------------------------------------------------------------------------------ ! START HERE @@ -210,6 +211,7 @@ PROGRAM WRFPOST if ( me >= num_procs ) then ! call server + ! else spval = 9.9e10 @@ -244,13 +246,10 @@ PROGRAM WRFPOST ! if (me==0) print*,'VALID TIME UNITS = ', VTIMEUNITS ! endif ! - 303 format('FULLMODELNAME="',A,'" MODELNAME="',A,'" & - SUBMODELNAME="',A,'"') write(0,*)'FULLMODELNAME: ', FULLMODELNAME ! MODELNAME, SUBMODELNAME - if (me==0) print 303,FULLMODELNAME,MODELNAME,SUBMODELNAME ! assume for now that the first date in the stdin file is the start date read(DateStr,300) iyear,imn,iday,ihrst,imin if (me==0) write(*,*) 'in WRFPOST iyear,imn,iday,ihrst,imin', & @@ -270,11 +269,11 @@ PROGRAM WRFPOST 120 format(a5) 121 format(a4) - if (me==0) print*,'MODELNAME= ',MODELNAME,'grib=',grib + if (me==0) print*,' MODELNAME= ',MODELNAME,'grib=',grib !Chuang: If model is GFS, read in flux file name from unit5 if(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') then read(5,111,end=117) fileNameFlux - if (me == 0) print*,'first two file names in GFS or FV3= ' & + if (me == 0) print*,' first two file names in GFS or FV3= ' & ,trim(fileName),trim(fileNameFlux) 117 continue @@ -762,19 +761,19 @@ PROGRAM WRFPOST IF(TRIM(IOFORM) == 'netcdf') THEN IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR') THEN - print*,'CALLING INITPOST TO PROCESS NCAR NETCDF OUTPUT' + print*,' CALLING INITPOST TO PROCESS NCAR NETCDF OUTPUT' CALL INITPOST ELSE IF(MODELNAME == 'NMM') THEN - print*,'CALLING INITPOST_NMM TO PROCESS NMM NETCDF OUTPUT' + print*,' CALLING INITPOST_NMM TO PROCESS NMM NETCDF OUTPUT' CALL INITPOST_NMM ELSE IF (MODELNAME == 'FV3R') THEN ! use netcdf library to read output directly spval = 9.99e20 - print*,'CALLING INITPOST_NETCDF' + if(me .eq. 0) print*,' CALLING INITPOST_NETCDF' CALL INITPOST_NETCDF(ncid3d) ELSE IF (MODELNAME == 'GFS') THEN spval = 9.99e20 - print*,'CALLING INITPOST_GFS_NETCDF' + print*,' CALLING INITPOST_GFS_NETCDF' CALL INITPOST_GFS_NETCDF(ncid3d) ELSE PRINT*,'POST does not have netcdf option for model,',MODELNAME,' STOPPING,' @@ -783,7 +782,7 @@ PROGRAM WRFPOST ! use netcdf_parallel library to read fv3 output ELSE IF(TRIM(IOFORM) == 'netcdfpara') THEN spval = 9.99e20 - print*,'CALLING INITPOST_GFS_NETCDF_PARA' + print*,' CALLING INITPOST_GFS_NETCDF_PARA',timef() CALL INITPOST_GFS_NETCDF_PARA(ncid3d) ELSE IF(TRIM(IOFORM) == 'binarympiio') THEN IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR' .OR. MODELNAME == 'NMM') THEN @@ -805,6 +804,7 @@ PROGRAM WRFPOST CALL INITPOST_NEMS(NREC,nfile) ELSE IF(MODELNAME == 'GFS') THEN ! CALL INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,nfile,ffile) + print*,' INITPOST_GFS_NEMS CALLED FOR GFS MODELNAME ' CALL INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,iostatusAER, & nfile,ffile,rfile) ELSE @@ -817,12 +817,14 @@ PROGRAM WRFPOST IF(MODELNAME == 'NMM') THEN ! close nemsio file for serial read call nemsio_close(nfile,iret=status) + print *,' INITPOST_NEMS_MPIIO called ' CALL INITPOST_NEMS_MPIIO() ELSE IF(MODELNAME == 'GFS') THEN ! close nemsio file for serial read call nemsio_close(nfile,iret=status) call nemsio_close(ffile,iret=status) call nemsio_close(rfile,iret=status) + print *,' INITPOST_NEMS_MPIIO called for GFS ' CALL INITPOST_GFS_NEMS_MPIIO(iostatusAER) ELSE PRINT*,'POST does not have nemsio mpi option for model,',MODELNAME, & @@ -845,15 +847,21 @@ PROGRAM WRFPOST INITPOST_tim = INITPOST_tim +(timef() - btim) time_initpost = time_initpost + timef() IF(ME == 0)THEN - WRITE(6,*)'WRFPOST: INITIALIZED POST COMMON BLOCKS' + WRITE(6,*)'WRFPOST: INITIALIZED POST COMMON BLOCKS', time_initpost,initpost_tim ENDIF + ta=timef() + call mpi_barrier(mpi_comm_comp,ierr) + tb=timef() + if(me .eq. 0) print *,' BARRIER 1,',tb-ta ! ! IF GRIB2 read out post aviable fields xml file and post control file ! if(grib == "grib2") then - btim=timef() +! btim=timef() + ta=timef() call READ_xml() READxml_tim = READxml_tim + (timef() - btim) + if(me .eq. 0) print *,' readxml_tim', timef()-ta,timef() endif ! ! LOOP OVER THE OUTPUT GRID(S). FIELD(S) AND OUTPUT GRID(S) ARE SPECIFIED @@ -885,10 +893,12 @@ PROGRAM WRFPOST ! (2) WRITE FIELD TO OUTPUT FILE IN GRIB. ! ! if (ieof == 0) then + t1=timef() ! CALL PROCESS(kth,kpv,th(1:kth),pv(1:kpv),iostatusD3D) ! IF(ME == 0)THEN -! WRITE(6,*)' ' -! WRITE(6,*)'WRFPOST: PREPARE TO PROCESS NEXT GRID' + t2=timef() +! WRITE(6,*)' WRFPOST: PREPARE TO PROCESS NEXT GRID',t2-t1,t2-btim + ! ENDIF ! endif ! @@ -901,6 +911,7 @@ PROGRAM WRFPOST if (me==0) write(0,*) ' in WRFPOST OUTFORM= ',grib if (me==0) write(0,*) ' GRIB1 IS NOT SUPPORTED ANYMORE' if (grib == "grib2") then + tf=timef() do while (npset < num_pset) npset = npset+1 if (me==0) write(0,*)' in WRFPOST npset=',npset,' num_pset=',num_pset @@ -921,21 +932,28 @@ PROGRAM WRFPOST if (me==0) write(0,*)'get_postfilename,post_fname=',trim(post_fname), & 'npset=',npset, 'num_pset=',num_pset, & 'iSF_SURFACE_PHYSICS=',iSF_SURFACE_PHYSICS + if(me .eq. 0) print *,' after postfiename time ',timef() ! ! PROCESS SELECTED FIELDS. FOR EACH SELECTED FIELD/LEVEL ! WE GO THROUGH THE FOLLOWING STEPS: ! (1) COMPUTE FIELD IF NEED BE ! (2) WRITE FIELD TO OUTPUT FILE IN GRIB. ! + t1=timef() + print *,' TIMEF BEFORE PROCESS',t1 CALL PROCESS(kth,kpv,th(1:kth),pv(1:kpv),iostatusD3D) IF(ME == 0) WRITE(6,*)'WRFPOST: PREPARE TO PROCESS NEXT GRID' ! ! write(0,*)'enter gribit2 before mpi_barrier' call mpi_barrier(mpi_comm_comp,ierr) + t2=timef() + if(me .eq. 0) print *,' PROCESS NEXT GRID',t2-t1,t2-btim ! if(me==0)call w3tage('bf grb2 ') ! write(0,*)'enter gribit2 after mpi barrier' + tc=timef() call gribit2(post_fname) + td=timef() deallocate(datapd) deallocate(fld_info) ! @@ -952,7 +970,10 @@ PROGRAM WRFPOST WRITE(6,*)' ' WRITE(6,*)'ALL GRIDS PROCESSED.' WRITE(6,*)' ' + print 305,' GWVX POSTIO compute and initialization TIME ',timef()-tf,time_initpost,initpost_tim + 305 format(a40,3f20.5) ENDIF + ! call DE_ALLOCATE @@ -960,6 +981,7 @@ PROGRAM WRFPOST 1000 CONTINUE !exp call ext_ncd_ioclose ( DataHandle, Status ) ! + if(me .eq. 0) then print*, 'INITPOST_tim = ', INITPOST_tim*1.0e-3 print*, 'MDLFLD_tim = ', ETAFLD2_tim*1.0e-3 print*, 'MDL2P_tim = ',ETA2P_tim *1.0e-3 @@ -972,6 +994,7 @@ PROGRAM WRFPOST print*, 'Time for OUTPUT = ',time_output print*, 'Time for INITPOST = ',time_initpost print*, 'Time for READxml = ',READxml_tim * 1.0e-3 + endif ! ! END OF PROGRAM. diff --git a/sorc/ncep_post.fd/grib2_module.f b/sorc/ncep_post.fd/grib2_module.f index b944d84d8..b3cec8c64 100644 --- a/sorc/ncep_post.fd/grib2_module.f +++ b/sorc/ncep_post.fd/grib2_module.f @@ -208,6 +208,7 @@ subroutine gribit2(post_fname) character(255),intent(in) :: post_fname ! !------- local variables + real*8 timef,ta,tb,tc,td,te,tf,tg,th integer i,j,k,n,nm,nprm,nlvl,fldlvl1,fldlvl2,cstart,cgrblen,ierr integer nf,nfpe,nmod integer fh, clength,lunout @@ -354,8 +355,11 @@ subroutine gribit2(post_fname) allocate(datafldtmp(im_jm*nfld_pe(me+1)) ) allocate(datafld(im_jm,nfld_pe(me+1)) ) ! + ta=timef() call mpi_alltoallv(datapd,iscnt,isdsp,MPI_REAL, & datafldtmp,ircnt,irdsp,MPI_REAL,MPI_COMM_COMP,ierr) + tb=timef() + if(me .eq. 0) print *,' GWVX GRIBIT2 alltoall ',tb-ta ! !--- re-arrange the data datafld=0. @@ -409,8 +413,12 @@ subroutine gribit2(post_fname) ! !--- generate grib2 message --- ! + ta=timef() call gengrb2msg(idisc,icatg, iparm,nprm,nlvl,fldlvl1,fldlvl2,ntrange, & leng_time_range_stat,datafld(:,i),cgrib(cstart),clength) + tb=timef() + if(me .eq. 0) print 301,' GWVX GRIB2 WRITE ',tb-ta,timef() + 301 format(a25,2f10.3) cstart=cstart+clength ! else From ce6c989c39606a96c43b181c2ed814f88dfcde3f Mon Sep 17 00:00:00 2001 From: George Vandenberghe Date: Thu, 1 Apr 2021 19:08:29 +0000 Subject: [PATCH 02/77] test of commit only added one comment to PROCESS.f --- sorc/ncep_post.fd/PROCESS.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sorc/ncep_post.fd/PROCESS.f b/sorc/ncep_post.fd/PROCESS.f index dfbf39471..65271ca0d 100644 --- a/sorc/ncep_post.fd/PROCESS.f +++ b/sorc/ncep_post.fd/PROCESS.f @@ -80,7 +80,7 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! ! COMPUTE/POST FIELDS ON MDL SURFACES. ! -! if(ifirstt .eq. 0 .and. me .eq. 0) call tracebackqq(' GWVX FROM PROCESS',-1) +!! if(ifirstt .eq. 0 .and. me .eq. 0) call tracebackqq(' GWVX FROM PROCESS',-1) btim = timef() CALL MDLFLD ETAFLD2_tim = ETAFLD2_tim +(timef() - btim) From 42e28965abe27b8ebf2f11c2b83697dc1cbb171f Mon Sep 17 00:00:00 2001 From: George Vandenberghe Date: Thu, 1 Apr 2021 19:12:08 +0000 Subject: [PATCH 03/77] comment test 2 --- sorc/ncep_post.fd/PROCESS.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sorc/ncep_post.fd/PROCESS.f b/sorc/ncep_post.fd/PROCESS.f index 65271ca0d..a82c346a4 100644 --- a/sorc/ncep_post.fd/PROCESS.f +++ b/sorc/ncep_post.fd/PROCESS.f @@ -80,7 +80,7 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! ! COMPUTE/POST FIELDS ON MDL SURFACES. ! -!! if(ifirstt .eq. 0 .and. me .eq. 0) call tracebackqq(' GWVX FROM PROCESS',-1) +!!! if(ifirstt .eq. 0 .and. me .eq. 0) call tracebackqq(' GWVX FROM PROCESS',-1) btim = timef() CALL MDLFLD ETAFLD2_tim = ETAFLD2_tim +(timef() - btim) From 5785961a4fbdc1bc657491510c04eccaf0b5086d Mon Sep 17 00:00:00 2001 From: George Vandenberghe Date: Tue, 27 Apr 2021 14:25:24 +0000 Subject: [PATCH 04/77] Added more routines to 2D decomposition --- sorc/ncep_post.fd/CLDRAD.f | 426 ++++++++++++++-------------- sorc/ncep_post.fd/MDL2AGL.f | 99 +++---- sorc/ncep_post.fd/MDL2P.f | 338 +++++++++++----------- sorc/ncep_post.fd/MDL2SIGMA.f | 99 +++---- sorc/ncep_post.fd/MDL2SIGMA2.f | 12 +- sorc/ncep_post.fd/MDLFLD.f | 489 ++++++++++++++++---------------- sorc/ncep_post.fd/MISCLN.f | 496 ++++++++++++++++----------------- sorc/ncep_post.fd/PROCESS.f | 2 +- 8 files changed, 982 insertions(+), 979 deletions(-) diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index 03712f590..f8176b90d 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -123,7 +123,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 + JM, LM, gocart_on, me,isx,iex use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD use gridspec_mod, only: dyval, gridtype use cmassi_mod, only: TRAD_ice @@ -140,10 +140,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(isx:iex,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(isx:iex,jsta:jend) :: GRID2, EGRID1, EGRID2, EGRID3, & CLDP, CLDZ, CLDT, CLDZCu REAL,dimension(lm) :: RHB, watericetotal, pabovesfc REAL :: watericemax, wimin, zcldbase, zcldtop, zpbltop, & @@ -158,7 +158,7 @@ SUBROUTINE CLDRAD ceil_min, ceil_neighbor real,dimension(im,jm) :: ceil ! B ZHOU: For aviation: - REAL, dimension(im,jsta:jend) :: TCLD, CEILING + REAL, dimension(isx:iex,jsta:jend) :: TCLD, CEILING real CU_ir(LM), q_conv !bsf !jw integer I,J,L,K,IBOT,ITCLOD,LBOT,LTOP,ITRDSW,ITRDLW, & @@ -168,8 +168,8 @@ SUBROUTINE CLDRAD ! real FULL_CLD(IM,JM) !-- Must be dimensioned for the full domain ! - real dummy(IM,jsta:jend) - integer idummy(IM,jsta:jend) + real dummy(isx:iex,jsta:jend) + integer idummy(isx:iex,jsta:jend) ! ! --- Revision added for GOCART --- @@ -214,7 +214,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(isx:iex,jsta:jend) :: P1D,T1D,Q1D,EGRID4 ! REAL, allocatable :: RH3D(:,:,:) ! RELATIVE HUMIDITY real, allocatable:: rdrh(:,:,:) integer, allocatable :: ihh(:,:,:) @@ -222,10 +222,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(isx:iex,jsta:jend) :: AOD_DU, AOD_SS, AOD_SU, AOD_OC, AOD_BC, AOD + REAL,dimension(isx:iex,jsta:jend) :: SCA_DU, SCA_SS, SCA_SU, SCA_OC,SCA_BC, SCA2D + REAL,dimension(isx:iex,jsta:jend) :: ASY_DU, ASY_SS, ASY_SU, ASY_OC, ASY_BC,ASY2D + REAL,dimension(isx:iex,jsta:jend) :: ANGST, AOD_440, AOD_860 ! FORANGSTROM EXPONENT REAL :: ANG1, ANG2 INTEGER :: INDX_EXT(nAero), INDX_SCA(nAero) LOGICAL :: LAEROPT, LEXT, LSCA, LASY @@ -264,7 +264,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=isx,iex EGRID1(I,J) = SPVAL ENDDO ENDDO @@ -274,14 +274,14 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'RAPR') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex 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=isx,iex IF(EGRID1(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) + TFRZ ENDDO ENDDO @@ -294,7 +294,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -309,7 +309,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex if (grid1(i,jj) /= spval) grid1(i,jj) = grid1(i,jj) - tfrz datapd(i,j,cfld) = GRID1(i,jj) enddo @@ -335,7 +335,7 @@ SUBROUTINE CLDRAD EGRID3,dummy,dummy) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(FIS(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -346,7 +346,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -363,7 +363,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=isx,iex IF(FIS(I,J) < SPVAL) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -377,7 +377,7 @@ SUBROUTINE CLDRAD EGRID3,dummy,dummy) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(FIS(I,J) < SPVAL) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -385,7 +385,7 @@ SUBROUTINE CLDRAD CALL BOUND(GRID1,D00,H99999) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(FIS(I,J) < SPVAL) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -395,7 +395,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -411,7 +411,7 @@ SUBROUTINE CLDRAD GRID1 = spval CALL CALPW(GRID1(1,jsta),1) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(FIS(I,J) >= SPVAL) GRID1(I,J)=spval END DO END DO @@ -422,7 +422,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -441,7 +441,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -460,7 +460,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -471,7 +471,7 @@ SUBROUTINE CLDRAD IF (IGET(200) > 0 .or. IGET(575) > 0) THEN IF (MODELNAME == 'RAPR') THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = LWP(I,J)/1000.0 ! use WRF-diagnosed value ENDDO ENDDO @@ -482,7 +482,7 @@ SUBROUTINE CLDRAD CALL CALPW(GRID2(1,jsta),3) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = GRID1(I,J) + GRID2(I,J) ENDDO ENDDO @@ -497,7 +497,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -510,7 +510,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -523,7 +523,7 @@ SUBROUTINE CLDRAD IF (IGET(201) > 0) THEN IF (MODELNAME == 'RAPR') THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = IWP(I,J)/1000.0 ! use WRF-diagnosed value ENDDO ENDDO @@ -537,7 +537,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -554,7 +554,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -571,7 +571,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -589,7 +589,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -607,7 +607,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -624,7 +624,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -641,7 +641,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -657,7 +657,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -673,7 +673,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -690,7 +690,7 @@ SUBROUTINE CLDRAD ENDIF !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = GRID1(I,J)*RRNUM ENDDO ENDDO @@ -723,7 +723,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -740,7 +740,7 @@ SUBROUTINE CLDRAD ENDIF !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = GRID1(I,J)*RRNUM ENDDO ENDDO @@ -773,7 +773,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -809,7 +809,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -819,7 +819,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=isx,iex GRID1(I,J)=-5000. GRID2(I,J)=-5000. !-- Search for the base first, then look for the top if supercooled liquid exists @@ -859,7 +859,7 @@ SUBROUTINE CLDRAD IF (IGET(288)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=GRID2(I,J) ENDDO ENDDO @@ -869,7 +869,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -882,7 +882,7 @@ 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=isx,iex GRID1(I,J) = CLDEFI(I,J) ENDDO ENDDO @@ -901,7 +901,7 @@ SUBROUTINE CLDRAD ! also a method for cloud ceiling height ! DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex CFRACL(I,J)=0. CFRACM(I,J)=0. CFRACH(I,J)=0. @@ -921,7 +921,7 @@ SUBROUTINE CLDRAD ! 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=isx,iex if(CFR(I,J,L)=PTOP_LOW) THEN @@ -1006,7 +1006,7 @@ SUBROUTINE CLDRAD IF (IGET(799)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=0.0 DO K = 1,LM IF (ZMID(I,J,LM-K+1) <= PBLH(I,J)+1000.0) THEN @@ -1026,7 +1026,7 @@ SUBROUTINE CLDRAD IF (IGET(037) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(CFRACL(I,J) < SPVAL) then GRID1(I,J) = CFRACL(I,J)*100. else @@ -1040,7 +1040,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1051,7 +1051,7 @@ SUBROUTINE CLDRAD IF (IGET(300) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(AVGCFRACL(I,J) < SPVAL) then GRID1(I,J) = AVGCFRACL(I,J)*100. else @@ -1090,7 +1090,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1102,7 +1102,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(CFRACM(I,J) < SPVAL) then GRID1(I,J) = CFRACM(I,J)*100. else @@ -1116,7 +1116,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1127,7 +1127,7 @@ SUBROUTINE CLDRAD IF (IGET(301) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(ABS(AVGCFRACM(I,J)-SPVAL)>SMALL)THEN GRID1(I,J) = AVGCFRACM(I,J)*100. ELSE @@ -1166,7 +1166,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1178,7 +1178,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(CFRACH(I,J) < SPVAL) then GRID1(I,J) = CFRACH(I,J)*100. else @@ -1192,7 +1192,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1204,7 +1204,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(AVGCFRACH(I,J) < SPVAL) then GRID1(I,J) = AVGCFRACH(I,J)*100. else @@ -1243,7 +1243,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1256,7 +1256,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=isx,iex GRID1(i,j) = SPVAL egrid1(i,j)=0. do l = 1,LM @@ -1268,7 +1268,7 @@ SUBROUTINE CLDRAD ELSE IF (MODELNAME=='NMM'.OR.MODELNAME=='FV3R' & .OR. MODELNAME=='GFS')THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ! 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))* & @@ -1280,7 +1280,7 @@ SUBROUTINE CLDRAD END IF !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex 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 @@ -1294,7 +1294,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1308,7 +1308,7 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(ABS(AVGTCDC(I,J)-SPVAL) > SMALL) then GRID1(I,J) = AVGTCDC(I,J)*100. else @@ -1319,7 +1319,7 @@ SUBROUTINE CLDRAD ELSE IF(MODELNAME == 'NMM')THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ! RSUM = NCFRST(I,J)+NCFRCV(I,J) ! IF (RSUM>0.0) THEN ! EGRID1(I,J)=(ACFRST(I,J)+ACFRCV(I,J))/RSUM @@ -1368,7 +1368,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1381,7 +1381,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF (NCFRST(I,J)>0.0) THEN GRID1(I,J) = ACFRST(I,J)/NCFRST(I,J)*100. ELSE @@ -1429,7 +1429,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF (NCFRCV(I,J)>0.0) THEN GRID1(I,J) = ACFRCV(I,J)/NCFRCV(I,J)*100. ELSE @@ -1485,7 +1485,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=isx,iex ! !--- Various convective cloud base & cloud top levels ! @@ -1616,7 +1616,7 @@ SUBROUTINE CLDRAD IF (IGET(758)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = CLDZCu(I,J) ENDDO ENDDO @@ -1635,7 +1635,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=isx,iex IBOT=IBOTT(I,J) !-- Cloud base ("bottoms") IF(MODELNAME == 'RAPR') then IF (IBOT <= 0) THEN @@ -1666,7 +1666,7 @@ SUBROUTINE CLDRAD ! CLOUD BOTTOM PRESSURE IF (IGET(148)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -1680,7 +1680,7 @@ SUBROUTINE CLDRAD 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=isx,iex GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -1719,7 +1719,7 @@ SUBROUTINE CLDRAD DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ! !- imported from RUC post IF(MODELNAME == 'RAPR') then @@ -1911,7 +1911,7 @@ SUBROUTINE CLDRAD nlifr = 0 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex zcld = CLDZ(i,j) - FIS(I,J)*GI if (CLDZ(i,j)>=0..and.zcld<160.) nlifr = nlifr+1 end do @@ -1922,7 +1922,7 @@ SUBROUTINE CLDRAD IF (IGET(408)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -1946,7 +1946,7 @@ SUBROUTINE CLDRAD ceiling_thresh_cldfra = 0.5 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ceil(I,J) = SPVAL zceil = SPVAL cldfra_max = 0. @@ -2017,7 +2017,7 @@ SUBROUTINE CLDRAD ! proceed to gridding DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = ceil(I,J) ENDDO ENDDO @@ -2047,7 +2047,7 @@ SUBROUTINE CLDRAD const1 = 3.912 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ceil(I,J) = SPVAL zceil = SPVAL zceil1 = SPVAL @@ -2165,7 +2165,7 @@ SUBROUTINE CLDRAD ! layer. numr = 1 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ceil_min = max( ceil(I,J)-FIS(I,J)*GI , 5.0) ! ceil_min in AGL do jc = max(JSTA,J-numr),min(JEND,J+numr) do ic = max(1,I-numr),min(IM,I+numr) @@ -2191,7 +2191,7 @@ SUBROUTINE CLDRAD IF (IGET(711)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -2206,7 +2206,7 @@ SUBROUTINE CLDRAD IF (IGET(798)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -2224,7 +2224,7 @@ SUBROUTINE CLDRAD IF (IGET(260)>0) THEN CALL CALCEILING(CLDZ,TCLD,CEILING) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = CEILING(I,J) ENDDO ENDDO @@ -2238,7 +2238,7 @@ SUBROUTINE CLDRAD IF (IGET(261) > 0) THEN CALL CALFLTCND(CEILING,GRID1(1,jsta)) ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=isx,iex ! GRID1(I,J) = FLTCND(I,J) ! ENDDO ! ENDDO @@ -2248,7 +2248,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2261,13 +2261,13 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = PBOT(I,J) ENDDO ENDDO ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IBOT=IBOTCu(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2283,7 +2283,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2294,7 +2294,7 @@ SUBROUTINE CLDRAD ! IF (IGET(192) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IBOT=IBOTDCu(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2313,7 +2313,7 @@ SUBROUTINE CLDRAD ! IF (IGET(190) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IBOT=IBOTSCu(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2332,7 +2332,7 @@ SUBROUTINE CLDRAD ! IF (IGET(194) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IBOT=IBOTGr(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2352,7 +2352,7 @@ SUBROUTINE CLDRAD ! IF (IGET(303) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ! IF(PBOTL(I,J) > SMALL)THEN GRID1(I,J) = PBOTL(I,J) ! ELSE @@ -2395,7 +2395,7 @@ SUBROUTINE CLDRAD ! IF (IGET(306) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(PBOTM(I,J) > SMALL)THEN GRID1(I,J) = PBOTM(I,J) ELSE @@ -2438,7 +2438,7 @@ SUBROUTINE CLDRAD ! IF (IGET(309) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(PBOTH(I,J) > SMALL)THEN GRID1(I,J) = PBOTH(I,J) ELSE @@ -2487,7 +2487,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=isx,iex 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=isx,iex GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -2537,7 +2537,7 @@ SUBROUTINE CLDRAD ! IF (IGET(179)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -2555,7 +2555,7 @@ SUBROUTINE CLDRAD Cloud_def_p = 0.0000001 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ! imported from RUC post ! Cloud top zcldtop = -5000. @@ -2619,7 +2619,7 @@ SUBROUTINE CLDRAD ! IF (IGET(406)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -2633,7 +2633,7 @@ SUBROUTINE CLDRAD ! IF (IGET(409)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -2649,7 +2649,7 @@ SUBROUTINE CLDRAD ! IF (IGET(168)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = CLDT(I,J) ENDDO ENDDO @@ -2665,7 +2665,7 @@ SUBROUTINE CLDRAD num_thick=0 ! for debug GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex opdepth=0. llmh=nint(lmh(i,j)) !bsf - start @@ -2765,13 +2765,13 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = PTOP(I,J) ENDDO ENDDO ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ITOP=ITOPCu(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2787,7 +2787,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2798,7 +2798,7 @@ SUBROUTINE CLDRAD ! IF (IGET(193) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ITOP=ITOPDCu(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2817,7 +2817,7 @@ SUBROUTINE CLDRAD ! IF (IGET(191) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ITOP=ITOPSCu(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2837,7 +2837,7 @@ SUBROUTINE CLDRAD ! IF (IGET(195) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ITOP=ITOPGr(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2857,7 +2857,7 @@ SUBROUTINE CLDRAD ! IF (IGET(304) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(PTOPL(I,J) > SMALL)THEN GRID1(I,J) = PTOPL(I,J) ELSE @@ -2900,7 +2900,7 @@ SUBROUTINE CLDRAD ! IF (IGET(307) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = PTOPM(I,J) ENDDO ENDDO @@ -2939,7 +2939,7 @@ SUBROUTINE CLDRAD ! IF (IGET(310) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = PTOPH(I,J) ENDDO ENDDO @@ -2979,7 +2979,7 @@ SUBROUTINE CLDRAD ! IF (IGET(305) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = TTOPL(I,J) ENDDO ENDDO @@ -3018,7 +3018,7 @@ SUBROUTINE CLDRAD ! IF (IGET(308) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = TTOPM(I,J) ENDDO ENDDO @@ -3057,7 +3057,7 @@ SUBROUTINE CLDRAD ! IF (IGET(311) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = TTOPH(I,J) ENDDO ENDDO @@ -3097,7 +3097,7 @@ SUBROUTINE CLDRAD IF (IGET(196) > 0.or.IGET(570)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex if(CNVCFR(I,J)/=SPVAL)GRID1(I,J)=100.*CNVCFR(I,J) !-- convert to percent ENDDO ENDDO @@ -3121,7 +3121,7 @@ SUBROUTINE CLDRAD IF (IGET(342) > 0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex if(PBLCFR(I,J)/=SPVAL)GRID1(I,J)=100.*PBLCFR(I,J) !-- convert to percent ENDDO ENDDO @@ -3161,7 +3161,7 @@ SUBROUTINE CLDRAD ! IF (IGET(313) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=cldwork(I,J) ENDDO ENDDO @@ -3213,7 +3213,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(ASWIN(I,J)/=SPVAL)THEN GRID1(I,J) = ASWIN(I,J)*RRNUM ELSE @@ -3266,7 +3266,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(AUVBIN(I,J)/=SPVAL)THEN GRID1(I,J) = AUVBIN(I,J)*RRNUM ELSE @@ -3320,7 +3320,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(AUVBINC(I,J)/=SPVAL)THEN GRID1(I,J) = AUVBINC(I,J)*RRNUM ELSE @@ -3373,7 +3373,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(ALWIN(I,J)/=SPVAL)THEN GRID1(I,J) = ALWIN(I,J)*RRNUM ELSE @@ -3425,7 +3425,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(ASWOUT(I,J)/=SPVAL)THEN GRID1(I,J) = -1.0*ASWOUT(I,J)*RRNUM ELSE @@ -3477,7 +3477,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(ALWOUT(I,J)/=SPVAL)THEN GRID1(I,J) = -1.0*ALWOUT(I,J)*RRNUM ELSE @@ -3529,7 +3529,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(ASWTOA(I,J)/=SPVAL)THEN GRID1(I,J) = ASWTOA(I,J)*RRNUM ELSE @@ -3581,7 +3581,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(ALWTOA(I,J)/=SPVAL)THEN GRID1(I,J) = ALWTOA(I,J)*RRNUM ELSE @@ -3627,7 +3627,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RLWTOA(I,J) ENDDO ENDDO @@ -3646,7 +3646,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(RLWTOA(I,J) < SPVAL) & & GRID1(I,J) = (RLWTOA(I,J)*STBOL)**0.25 ENDDO @@ -3662,7 +3662,7 @@ SUBROUTINE CLDRAD ! CURRENT INCOMING SW RADIATION AT THE SURFACE. IF (IGET(156)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(CZMEAN(I,J)>1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE @@ -3684,7 +3684,7 @@ SUBROUTINE CLDRAD ! dong add missing value to DLWRF GRID1 = spval DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(MODELNAME=='RSM' .OR. MODELNAME == 'RAPR') THEN !add by Binbin: RSM has direct RLWIN output GRID1(I,J)=RLWIN(I,J) ELSE @@ -3711,7 +3711,7 @@ SUBROUTINE CLDRAD IF (IGET(141)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(CZMEAN(I,J)>1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE @@ -3731,7 +3731,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky upwelling SW at the surface IF (IGET(743)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = SWUPBC(I,J) ENDDO ENDDO @@ -3746,7 +3746,7 @@ SUBROUTINE CLDRAD IF (IGET(142)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RADOT(I,J) ENDDO ENDDO @@ -3760,7 +3760,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky downwelling LW at the surface IF (IGET(744)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = LWDNBC(I,J) ENDDO ENDDO @@ -3774,7 +3774,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky upwelling LW at the surface IF (IGET(745)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = LWUPBC(I,J) ENDDO ENDDO @@ -3789,7 +3789,7 @@ SUBROUTINE CLDRAD IF (IGET(740)>0) THEN print *,"GETTING INTO MEAN_FRP PART" DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = MEAN_FRP(I,J) ENDDO ENDDO @@ -3805,7 +3805,7 @@ SUBROUTINE CLDRAD IF (IGET(262)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(CZMEAN(I,J)>1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE @@ -3824,7 +3824,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky downwelling SW at surface (GSD version) IF (IGET(742)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = SWDNBC(I,J) ENDDO ENDDO @@ -3839,7 +3839,7 @@ SUBROUTINE CLDRAD IF (IGET(772)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = SWDDNI(I,J) ENDDO ENDDO @@ -3853,7 +3853,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky SWDDNI IF (IGET(796)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = SWDDNIC(I,J) ENDDO ENDDO @@ -3868,7 +3868,7 @@ SUBROUTINE CLDRAD IF (IGET(773)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = SWDDIF(I,J) ENDDO ENDDO @@ -3882,7 +3882,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky SWDDIF IF (IGET(797)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = SWDDIFC(I,J) ENDDO ENDDO @@ -3896,7 +3896,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED INCOMING CLEARSKY SW RADIATION AT THE SURFACE. IF (IGET(383)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = ASWINC(I,J) ENDDO ENDDO @@ -3934,7 +3934,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY SW RADIATION AT THE SURFACE. IF (IGET(386)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = ASWOUTC(I,J) ENDDO ENDDO @@ -3972,7 +3972,7 @@ SUBROUTINE CLDRAD ! 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=isx,iex GRID1(I,J) = SWUPT(I,J) ENDDO ENDDO @@ -3986,7 +3986,7 @@ SUBROUTINE CLDRAD ! 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=isx,iex GRID1(I,J) = ASWTOAC(I,J) ENDDO ENDDO @@ -4024,7 +4024,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED INCOMING SW RADIATION AT THE MODEL TOP IF (IGET(388)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = ASWINTOA(I,J) ENDDO ENDDO @@ -4062,7 +4062,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED INCOMING CLEARSKY LW RADIATION AT THE SURFACE IF (IGET(382)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = ALWINC(I,J) ENDDO ENDDO @@ -4100,7 +4100,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY LW RADIATION AT THE SURFACE IF (IGET(384)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = ALWOUTC(I,J) ENDDO ENDDO @@ -4138,7 +4138,7 @@ SUBROUTINE CLDRAD ! 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=isx,iex GRID1(I,J) = ALWTOAC(I,J) ENDDO ENDDO @@ -4176,7 +4176,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE BEAM DOWNWARD SOLAR FLUX IF (IGET(401)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = AVISBEAMSWIN(I,J) ENDDO ENDDO @@ -4216,7 +4216,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE DIFFUSE DOWNWARD SOLAR FLUX IF (IGET(402)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = AVISDIFFSWIN(I,J) ENDDO ENDDO @@ -4255,7 +4255,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE BEAM DOWNWARD SOLAR FLUX IF (IGET(403)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = AIRBEAMSWIN(I,J) ENDDO ENDDO @@ -4294,7 +4294,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE DIFFUSE DOWNWARD SOLAR FLUX IF (IGET(404)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = AIRDIFFSWIN(I,J) ENDDO ENDDO @@ -4333,7 +4333,7 @@ SUBROUTINE CLDRAD !2D AEROSOL OPTICAL DEPTH AT 550 NM IF (IGET(715)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex grid1(i,j)=taod5502d(i,j) ENDDO ENDDO @@ -4347,7 +4347,7 @@ SUBROUTINE CLDRAD !AEROSOL ASYMMETRY FACTOR IF (IGET(716)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex grid1(i,j)=aerasy2d(i,j) ENDDO ENDDO @@ -4361,7 +4361,7 @@ SUBROUTINE CLDRAD !AEROSOL SINGLE-SCATTERING ALBEDO IF (IGET(717)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex grid1(i,j)=aerssa2d(i,j) ENDDO ENDDO @@ -4551,13 +4551,13 @@ SUBROUTINE CLDRAD !!! COMPUTES RELATIVE HUMIDITY AND RDRH ! allocate (RH3D(im,jsta:jend,lm)) - allocate (rdrh(im,jsta:jend,lm)) - allocate (ihh(im,jsta:jend,lm)) + allocate (rdrh(isx:iex,jsta:jend,lm)) + allocate (ihh(isx:iex,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=isx,iex P1D(I,J) = PMID(I,J,LL) T1D(I,J) = T(I,J,LL) Q1D(I,J) = Q(I,J,LL) @@ -4565,7 +4565,7 @@ SUBROUTINE CLDRAD ENDDO CALL CALRH(P1D,T1D,Q1D,EGRID4) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ! RH3D(I,J,LL) = EGRID4(I,J) RH3D = EGRID4(I,J) ! DETERMINE RDRH (wgt for IH2) and IHH (index for IH2) @@ -4653,7 +4653,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex DO L=1,LM DO N=1, NBIN_DU EXT01 = EXTRHD_DU(1,N,IB) @@ -4680,7 +4680,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex DO L=1,LM ih1 = ihh(I,J,L) ih2 = ih1 + 1 @@ -4714,7 +4714,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4747,7 +4747,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4779,7 +4779,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4809,7 +4809,7 @@ SUBROUTINE CLDRAD SCA=SPVAL ASY=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex 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) @@ -4841,7 +4841,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=isx,iex AOD_440(I,J) = AOD(I,J) ENDDO ! I-loop ENDDO ! J-loop @@ -4850,7 +4850,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=isx,iex AOD_860(I,J) = AOD(I,J) ENDDO ! I-loop ENDDO ! J-loop @@ -4861,7 +4861,7 @@ SUBROUTINE CLDRAD IF ( IGET(INDX) > 0) THEN !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=isx,iex GRID1(i,j) = AOD(i,j) enddo enddo @@ -4880,7 +4880,7 @@ SUBROUTINE CLDRAD IF ( IGET(649) > 0 ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF ( SCA2D(I,J) > 0.0 ) THEN ASY2D(I,J) = ASY2D(I,J) / SCA2D(I,J) ELSE @@ -4901,7 +4901,7 @@ SUBROUTINE CLDRAD IF ( IGET(648) > 0 ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF ( AOD(I,J) > 0.0 ) THEN SCA2D(I,J) = SCA2D(I,J) / AOD(I,J) ELSE @@ -4930,7 +4930,7 @@ SUBROUTINE CLDRAD IF ( IGET(650) > 0 ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=SCA2D(I,J) ENDDO ENDDO @@ -4949,7 +4949,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=isx,iex 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) @@ -4970,7 +4970,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=isx,iex 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) @@ -4999,7 +4999,7 @@ SUBROUTINE CLDRAD ANG2 = LOG ( 860. / 440. ) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF (AOD_860(I,J) > 0.) THEN ANG1 = LOG( AOD_440(I,J)/AOD_860(I,J) ) ANGST(I,J) = ANG1 / ANG2 @@ -5024,7 +5024,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex GRID1(I,J) = DUEM(I,J,1)*1.E-6 DO K=2,NBIN_DU GRID1(I,J) = GRID1(I,J) + DUEM(I,J,K)*1.E-6 @@ -5042,7 +5042,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex GRID1(I,J) = DUSD(I,J,1)*1.E-6 DO K=2,NBIN_DU GRID1(I,J) = GRID1(I,J)+ DUSD(I,J,K)*1.E-6 @@ -5059,7 +5059,7 @@ SUBROUTINE CLDRAD ! ! IF (IGET(661)>0) THEN ! DO J = JSTA,JEND -! DO I = 1,IM +! DO I = isx,iex ! 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 @@ -5069,7 +5069,7 @@ SUBROUTINE CLDRAD ! ID(1:25) = 0 ! ID(02)=141 ! if(grib=='grib1') then -! CALL GRIBIT(IGET(661),LVLS(1,IGET(661)),GRID1,IM,JM) +! CALL GRIBIT(IGET(661),LVLS(1,IGET(661)),GRIDisx,iex,JM) ! elseif(grib=='grib2') then ! cfld=cfld+1 ! fld_info(cfld)%ifld=IAVBLFLD(IGET(661)) @@ -5081,7 +5081,7 @@ SUBROUTINE CLDRAD IF (IGET(686)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = DUSTPM(I,J) !ug/m3 END DO @@ -5096,7 +5096,7 @@ SUBROUTINE CLDRAD !! ADD DUST WET DEPOSITION FLUXES (kg/m2/sec) ! IF (IGET(662)>0) THEN ! DO J = JSTA,JEND -! DO I = 1,IM +! DO I = isx,iex ! 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 @@ -5106,7 +5106,7 @@ SUBROUTINE CLDRAD ! ID(1:25) = 0 ! ID(02)=141 ! if(grib=='grib1') then -! CALL GRIBIT(IGET(662),LVLS(1,IGET(662)),GRID1,IM,JM) +! CALL GRIBIT(IGET(662),LVLS(1,IGET(662)),GRIDisx,iex,JM) ! elseif(grib=='grib2') then ! cfld=cfld+1 ! fld_info(cfld)%ifld=IAVBLFLD(IGET(662)) @@ -5118,7 +5118,7 @@ SUBROUTINE CLDRAD IF (IGET(684)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = SSPM(I,J) !ug/m3 END DO @@ -5133,7 +5133,7 @@ SUBROUTINE CLDRAD IF (IGET(619)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = DUSMASS(I,J) !ug/m3 END DO @@ -5149,7 +5149,7 @@ SUBROUTINE CLDRAD IF (IGET(620)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex !GRID1(I,J) = DUSMASS25(I,J) * 1.E-6 GRID1(I,J) = DUSMASS25(I,J) ! ug/m3 END DO @@ -5164,7 +5164,7 @@ SUBROUTINE CLDRAD IF (IGET(621)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex !GRID1(I,J) = DUCMASS(I,J) * 1.E-6 GRID1(I,J) = DUCMASS(I,J) * 1.E-9 END DO @@ -5180,7 +5180,7 @@ SUBROUTINE CLDRAD IF (IGET(622)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex !GRID1(I,J) = DUCMASS25(I,J) * 1.E-6 GRID1(I,J) = DUCMASS25(I,J) * 1.E-9 END DO @@ -5196,7 +5196,7 @@ SUBROUTINE CLDRAD IF (IGET(646)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex GRID1(I,J) = DUSTCB(I,J) * 1.E-9 END DO END DO @@ -5211,7 +5211,7 @@ SUBROUTINE CLDRAD IF (IGET(647)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex GRID1(I,J) = SSCB(I,J) * 1.E-9 END DO END DO @@ -5225,7 +5225,7 @@ SUBROUTINE CLDRAD IF (IGET(616)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex GRID1(I,J) = BCCB(I,J) * 1.E-9 END DO END DO @@ -5240,7 +5240,7 @@ SUBROUTINE CLDRAD IF (IGET(617)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex GRID1(I,J) = OCCB(I,J) * 1.E-9 END DO END DO @@ -5255,7 +5255,7 @@ SUBROUTINE CLDRAD IF (IGET(618)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex GRID1(I,J) = SULFCB(I,J) * 1.E-9 END DO END DO @@ -5313,7 +5313,7 @@ SUBROUTINE CLDRAD ! CB cover is derived from CPRAT (same as #272 in SURFCE.f) EGRID1 = SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex if(AVGCPRATE(I,J) /= SPVAL) then EGRID1(I,J) = AVGCPRATE(I,J)*(1000./DTQ2) end if @@ -5327,7 +5327,7 @@ SUBROUTINE CLDRAD EGRID3 = SPVAL IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') then DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EGRID2(I,J) = PBOT(I,J) EGRID3(I,J) = PTOP(I,J) END DO @@ -5336,7 +5336,7 @@ SUBROUTINE CLDRAD ! Derive CB base and top, relationship among CB fields DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex if(EGRID1(I,J)<= 0. .or. EGRID2(I,J)<= 0. .or. EGRID3(I,J) <= 0.) then EGRID1(I,J) = SPVAL EGRID2(I,J) = SPVAL @@ -5345,7 +5345,7 @@ SUBROUTINE CLDRAD END DO END DO DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(EGRID2(I,J) == SPVAL .or. EGRID3(I,J) == SPVAL) cycle if(EGRID3(I,J) < 400.*100. .and. & (EGRID2(I,J)-EGRID3(I,J)) > 300.*100) then @@ -5394,7 +5394,7 @@ SUBROUTINE CLDRAD IF(IGET(473) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -5403,7 +5403,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5412,7 +5412,7 @@ SUBROUTINE CLDRAD IF(IGET(474) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID2(I,J) ENDDO ENDDO @@ -5421,7 +5421,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5430,7 +5430,7 @@ SUBROUTINE CLDRAD IF(IGET(475) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -5439,7 +5439,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5456,7 +5456,7 @@ 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,isx,iex implicit none real, intent(inout) :: cbcov(IM,JSTA:JEND) @@ -5509,7 +5509,7 @@ 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,isx,iex use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD implicit none ! @@ -5522,7 +5522,7 @@ subroutine wrt_aero_diag(igetfld,nbin,data) GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = isx,iex grid1(I,J) = data(I,J,1) DO K=2,NBIN GRID1(I,J) = GRID1(I,J)+ data(I,J,K) diff --git a/sorc/ncep_post.fd/MDL2AGL.f b/sorc/ncep_post.fd/MDL2AGL.f index 03333e058..7ee65b9e5 100644 --- a/sorc/ncep_post.fd/MDL2AGL.f +++ b/sorc/ncep_post.fd/MDL2AGL.f @@ -13,6 +13,7 @@ !! 11-03-04 J WANG - ADD grib2 option !! 19-10-30 B CUI - REMOVE "GOTO" STATEMENT !! 20-03-25 J MENG - remove grib1 +!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) !! !! USAGE: CALL MDL2P !! INPUT ARGUMENT LIST: @@ -58,7 +59,7 @@ 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,isx,iex use rqstfld_mod, only: iget, lvls, iavblfld, lvlsxml, id use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -74,10 +75,10 @@ SUBROUTINE MDL2AGL ! DECLARE VARIABLES. ! LOGICAL IOOMG,IOALL - REAL,dimension(im,jm) :: grid1 - REAL,dimension(im,jsta_2l:jend_2u) :: UAGL, VAGL, tagl, pagl, qagl + REAL,dimension(im,jsta_2l:jend_2u) :: grid1 + REAL,dimension(isx:iex,jsta_2l:jend_2u) :: UAGL, VAGL, tagl, pagl, qagl ! - INTEGER,dimension(im,jsta_2l:jend_2u) :: NL1X + INTEGER,dimension(isx:iex,jsta_2l:jend_2u) :: NL1X integer,dimension(jm) :: IHE, IHW INTEGER LXXX,IERR, maxll, minll INTEGER ISTART,ISTOP,JSTART,JSTOP @@ -97,7 +98,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(isx:iex,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,7 +150,7 @@ SUBROUTINE MDL2AGL ii=float(im)/3.0 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex DBZ1(I,J) = SPVAL DBZR1(I,J) = SPVAL DBZI1(I,J) = SPVAL @@ -192,7 +193,7 @@ SUBROUTINE MDL2AGL ! DO 220 J=JSTA,JEND DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex LL = NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -275,13 +276,13 @@ SUBROUTINE MDL2AGL IF((IGET(253)>0) )THEN if(MODELNAME=='RAPR') then DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=DBZ1LOG(I,J) ENDDO ENDDO else DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=DBZ1(I,J) ENDDO ENDDO @@ -296,7 +297,7 @@ SUBROUTINE MDL2AGL !--- Radar reflectivity from rain IF((IGET(279)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=DBZR1(I,J) ENDDO ENDDO @@ -310,7 +311,7 @@ SUBROUTINE MDL2AGL !--- 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=isx,iex GRID1(I,J)=DBZI1(I,J) ENDDO ENDDO @@ -324,7 +325,7 @@ SUBROUTINE MDL2AGL !--- Radar reflectivity from parameterized convection IF((IGET(281)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=DBZC1(I,J) ENDDO ENDDO @@ -349,7 +350,7 @@ SUBROUTINE MDL2AGL !--- Max Derived Radar Reflectivity IF((IGET(421)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=REFD_MAX(I,J) ENDDO ENDDO @@ -371,7 +372,7 @@ SUBROUTINE MDL2AGL !--- Max Derived Radar Reflectivity at -10C IF((IGET(785)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=REFDM10C_MAX(I,J) ENDDO ENDDO @@ -392,7 +393,7 @@ SUBROUTINE MDL2AGL !--- Max Updraft Helicity IF((IGET(420)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=UP_HELI_MAX(I,J) ENDDO ENDDO @@ -413,7 +414,7 @@ SUBROUTINE MDL2AGL !--- Max Updraft Helicity 1-6 km IF((IGET(700)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=UP_HELI_MAX16(I,J) ENDDO ENDDO @@ -434,7 +435,7 @@ SUBROUTINE MDL2AGL !--- Min Updraft Helicity IF((IGET(786)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=UP_HELI_MIN(I,J) ENDDO ENDDO @@ -455,7 +456,7 @@ SUBROUTINE MDL2AGL !--- Min Updraft Helicity 1-6 km IF((IGET(787)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=UP_HELI_MIN16(I,J) ENDDO ENDDO @@ -476,7 +477,7 @@ SUBROUTINE MDL2AGL !--- Max Updraft Helicity 0-2 km IF((IGET(788)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=UP_HELI_MAX02(I,J) ENDDO ENDDO @@ -496,7 +497,7 @@ SUBROUTINE MDL2AGL !--- Min Updraft Helicity 0-2 km IF((IGET(789)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=UP_HELI_MIN02(I,J) ENDDO ENDDO @@ -517,7 +518,7 @@ SUBROUTINE MDL2AGL !--- Max Updraft Helicity 0-3 km IF((IGET(790)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=UP_HELI_MAX03(I,J) ENDDO ENDDO @@ -538,7 +539,7 @@ SUBROUTINE MDL2AGL !--- Min Updraft Helicity 0-3 km IF((IGET(791)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=UP_HELI_MIN03(I,J) ENDDO ENDDO @@ -559,7 +560,7 @@ SUBROUTINE MDL2AGL !--- Max Relative Vertical Vorticity 0-2 km IF((IGET(792)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=REL_VORT_MAX(I,J) ENDDO ENDDO @@ -580,7 +581,7 @@ SUBROUTINE MDL2AGL !--- Max Relative Vertical Vorticity 0-1 km IF((IGET(793)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=REL_VORT_MAX01(I,J) ENDDO ENDDO @@ -600,7 +601,7 @@ SUBROUTINE MDL2AGL !--- Max Relative Vertical Vorticity @ hybrid level 1 IF((IGET(890)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=REL_VORT_MAXHY1(I,J) ENDDO ENDDO @@ -621,7 +622,7 @@ SUBROUTINE MDL2AGL !--- Max Hail Diameter in Column IF((IGET(794)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=HAIL_MAX2D(I,J) ENDDO ENDDO @@ -642,7 +643,7 @@ SUBROUTINE MDL2AGL !--- Max Hail Diameter at k=1 IF((IGET(795)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=HAIL_MAXK1(I,J) ENDDO ENDDO @@ -665,7 +666,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=isx,iex GRID1(I,J)=HAIL_MAXHAILCAST(I,J)/1000.0 ! convert mm to m ENDDO ENDDO @@ -686,7 +687,7 @@ SUBROUTINE MDL2AGL !--- Max Column Integrated Graupel IF((IGET(429)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=GRPL_MAX(I,J) ENDDO ENDDO @@ -707,7 +708,7 @@ SUBROUTINE MDL2AGL !--- Max Lightning Threat 1 IF((IGET(702)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=LTG1_MAX(I,J) ENDDO ENDDO @@ -728,7 +729,7 @@ SUBROUTINE MDL2AGL !--- Max Lightning Threat 2 IF((IGET(703)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=LTG2_MAX(I,J) ENDDO ENDDO @@ -749,7 +750,7 @@ SUBROUTINE MDL2AGL !--- Max Lightning Threat 3 IF((IGET(704)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=LTG3_MAX(I,J) ENDDO ENDDO @@ -770,7 +771,7 @@ SUBROUTINE MDL2AGL !--- GSD Updraft Helicity IF((IGET(727)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=UP_HELI(I,J) ENDDO ENDDO @@ -785,7 +786,7 @@ SUBROUTINE MDL2AGL !--- Updraft Helicity 1-6 km layer IF((IGET(701)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=UP_HELI16(I,J) ENDDO ENDDO @@ -800,7 +801,7 @@ SUBROUTINE MDL2AGL !--- Convective Initiation Lightning IF((IGET(705)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=NCI_LTG(I,J)/60.0 ENDDO ENDDO @@ -821,7 +822,7 @@ SUBROUTINE MDL2AGL !--- Convective Activity Lightning IF((IGET(706)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=NCA_LTG(I,J)/60.0 ENDDO ENDDO @@ -842,7 +843,7 @@ SUBROUTINE MDL2AGL !--- Convective Initiation Vertical Hydrometeor Flux IF((IGET(707)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=NCI_WQ(I,J)/60.0 ENDDO ENDDO @@ -863,7 +864,7 @@ SUBROUTINE MDL2AGL !--- Convective Activity Vertical Hydrometeor Flux IF((IGET(708)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=NCA_WQ(I,J)/60.0 ENDDO ENDDO @@ -884,7 +885,7 @@ SUBROUTINE MDL2AGL !--- Convective Initiation Reflectivity IF((IGET(709)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=NCI_REFD(I,J)/60.0 ENDDO ENDDO @@ -905,7 +906,7 @@ SUBROUTINE MDL2AGL !--- Convective Activity Reflectivity IF((IGET(710)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=NCA_REFD(I,J)/60.0 ENDDO ENDDO @@ -945,7 +946,7 @@ SUBROUTINE MDL2AGL jj=(jsta+jend)/2 ii=(im)/2 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex UAGL(I,J) = SPVAL VAGL(I,J) = SPVAL ! @@ -1007,10 +1008,10 @@ SUBROUTINE MDL2AGL IF(gridtype/='A')THEN ! MAXLL=maxval(NL1X) MINLL=minval(NL1X) - print*,'MINLL before all reduce= ',MINLL +! print*,'MINLL before all reduce= ',MINLL CALL MPI_ALLREDUCE(MINLL,LXXX,1,MPI_INTEGER,MPI_MIN,MPI_COMM_COMP,IERR) MINLL=LXXX - print*,'exchange wind in MDL2AGL from ',MINLL +! 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)) @@ -1122,7 +1123,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=isx,iex IF(ABS(UAGL(I,J)-SPVAL)>SMALL .AND. & ABS(VAGL(I,J)-SPVAL)>SMALL)THEN IF(GRIDTYPE=='B' .OR. GRIDTYPE=='E')THEN @@ -1174,7 +1175,7 @@ SUBROUTINE MDL2AGL jj = float(jsta+jend)/2.0 ii = float(im)/3.0 DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=isx,iex ! PAGL(I,J) = SPVAL TAGL(I,J) = SPVAL @@ -1218,7 +1219,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=isx,iex LL = NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -1289,7 +1290,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=isx,iex QAGL(I,J)=QAGL(I,J)/1000.0 PV=QAGL(I,J)*PAGL(I,J)/(EPS*(1-QAGL(I,J)) + QAGL(I,J)) RHO=(1/TAGL(I,J))*(((PAGL(I,J)-PV)/RD) + PV/461.495) @@ -1306,7 +1307,7 @@ SUBROUTINE MDL2AGL !--- U Component of wind IF((IGET(412)>0) ) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=UAGL(I,J) ENDDO ENDDO @@ -1320,7 +1321,7 @@ SUBROUTINE MDL2AGL !--- V Component of wind IF((IGET(413)>0) ) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=VAGL(I,J) ENDDO ENDDO diff --git a/sorc/ncep_post.fd/MDL2P.f b/sorc/ncep_post.fd/MDL2P.f index 31de5ed59..c1a9cc364 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -81,7 +81,7 @@ 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,isx,iex use rqstfld_mod, only: IGET, LVLS, ID, IAVBLFLD, LVLSXML use gridspec_mod, only: GRIDTYPE, MAPTYPE, DXVAL use upp_physics, only: FPVSNEW, CALRH @@ -101,7 +101,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(isx:iex,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL & &, Q2SL, WSL, CFRSL, O3SL, TDSL & &, EGRID1, EGRID2 & &, FSL_OLD, USL_OLD, VSL_OLD & @@ -110,8 +110,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(isx:iex,jsta_2l:jend_2u) :: NL1X, NL1XF + real, dimension(isx:iex,JSTA_2L:JEND_2U,LSM) :: TPRS, QPRS, FPRS ! INTEGER K, NSMOOTH ! @@ -131,7 +131,7 @@ SUBROUTINE MDL2P(iostatusD3D) REAL SDUMMY(IM,2) ! SAVE RH, U,V, for Icing, CAT, LLWS computation - REAL SAVRH(IM,jsta:jend) + REAL SAVRH(isx:iex,jsta:jend) !jw integer I,J,L,LP,LL,LLMH,JJB,JJE,II,JJ,LI,IFINCR,ITD3D,ista,imois,luhi,la real fact,ALPSL,PSFC,QBLO,PNL1,TBLO,TVRL,TVRBLO,FAC,PSLPIJ, & @@ -153,7 +153,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,l) do l=1,27 do j=1,jm - do i=1,im + do i=isx,iex D3DSL(i,j,l) = SPVAL enddo enddo @@ -164,7 +164,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,l) do l=1,nbin_du do j=1,jm - do i=1,im + do i=isx,iex DUSTSL(i,j,l) = SPVAL enddo enddo @@ -174,7 +174,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,l) do l=1,nbin_sm do j=1,jm - do i=1,im + do i=isx,iex SMOKESL(i,j,l) = SPVAL enddo enddo @@ -248,7 +248,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! !$omp parallel do private(i,j,l) DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=isx,iex TSL(I,J) = SPVAL QSL(I,J) = SPVAL FSL(I,J) = SPVAL @@ -314,7 +314,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$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=isx,iex !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC !*** HUMIDITY, CLOUD WATER/ICE, OMEGA, WINDS, AND TKE. @@ -782,7 +782,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex TPRS(I,J,LP) = TSL(I,J) QPRS(I,J,LP) = QSL(I,J) FPRS(I,J,LP) = FSL(I,J) @@ -867,7 +867,7 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO ! DO J=JSTA,JEND - DO I=1,IM-MOD(j,2) + DO I=isx,iex-MOD(j,2) LL = NL1X(I,J) !--------------------------------------------------------------------- @@ -922,7 +922,7 @@ SUBROUTINE MDL2P(iostatusD3D) END DO ELSE IF(gridtype=='B')THEN ! B grid wind interpolation DO J=JSTA,JEND_m - DO I=1,IM-1 + DO I=isx,iex-1 !*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. ! @@ -952,7 +952,7 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO ! DO J=JSTA,JEND_m - DO I=1,IM-1 + DO I=isx,iex-1 LL = NL1X(I,J) !--------------------------------------------------------------------- @@ -1010,7 +1010,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=isx,iex T500(I,J) = TSL(I,J) ENDDO ENDDO @@ -1028,7 +1028,7 @@ SUBROUTINE MDL2P(iostatusD3D) !HC ALPTH=LOG(1.E5) !HC!$omp parallel do private(i,j) !HC DO J=JSTA,JEND -!HC DO I=1,IM +!HC DO I=isx,iex !HC IF(FSL(I,J) < SPVAL) THEN !HC PSLPIJ=PSLP(I,J) !HC ALPSL=LOG(PSLPIJ) @@ -1052,7 +1052,7 @@ SUBROUTINE MDL2P(iostatusD3D) !HC IF(IGET(023)<=0.AND.LP == LSM)THEN !!$omp parallel do private(i,j) !HC DO J=JSTA,JEND -!HC DO I=1,IM +!HC DO I=isx,iex !HC IF(Z1000(I,J) < SPVAL) THEN !HC FSL(I,J)=Z1000(I,J)*G !HC ELSE @@ -1080,7 +1080,7 @@ SUBROUTINE MDL2P(iostatusD3D) ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(FSL(I,J) < SPVAL) THEN GRID1(I,J) = FSL(I,J)*GI ELSE @@ -1115,7 +1115,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1131,7 +1131,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=isx,iex GRID1(I,J) = TSL(I,J) ENDDO ENDDO @@ -1151,7 +1151,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1165,7 +1165,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=isx,iex GRID1(I,J) = TSL(I,J)*(1.+0.608*QSL(I,J)) ENDDO ENDDO @@ -1185,7 +1185,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1202,7 +1202,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=isx,iex IF(TSL(I,J) < SPVAL) THEN grid1(I,J) = TSL(I,J) * tem ELSE @@ -1212,7 +1212,7 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO !!$omp parallel do private(i,j) ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=isx,iex ! EGRID2(I,J) = SPL(LP) ! ENDDO ! ENDDO @@ -1220,7 +1220,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! CALL CALPOT(EGRID2,TSL,EGRID1) !!$omp parallel do private(i,j) ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=isx,iex ! GRID1(I,J) = EGRID1(I,J) ! ENDDO ! ENDDO @@ -1232,7 +1232,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1256,7 +1256,7 @@ SUBROUTINE MDL2P(iostatusD3D) if ( log1 ) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EGRID2(I,J) = SPL(LP) ENDDO ENDDO @@ -1265,7 +1265,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(EGRID1(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J)*100. ELSE @@ -1288,7 +1288,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1296,7 +1296,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex SAVRH(I,J) = GRID1(I,J) ENDDO ENDDO @@ -1310,7 +1310,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=isx,iex CFRSL(I,J) = MIN(MAX(0.0,CFRSL(I,J)),1.0) IF(abs(CFRSL(I,J)-SPVAL) > SMALL) & GRID1(I,J) = CFRSL(I,J)*H100 @@ -1323,7 +1323,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1337,7 +1337,7 @@ 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=isx,iex EGRID2(I,J) = SPL(LP) ENDDO ENDDO @@ -1345,7 +1345,7 @@ SUBROUTINE MDL2P(iostatusD3D) CALL CALDWP(EGRID2(1,jsta),QSL(1,jsta),EGRID1(1,jsta),TSL(1,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(TSL(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J) ELSE @@ -1360,7 +1360,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1374,7 +1374,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=isx,iex GRID1(I,J) = QSL(I,J) ENDDO ENDDO @@ -1386,7 +1386,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1400,7 +1400,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=isx,iex GRID1(I,J) = OSL(I,J) ENDDO ENDDO @@ -1429,7 +1429,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1443,7 +1443,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=isx,iex GRID1(I,J) = WSL(I,J) ENDDO ENDDO @@ -1454,7 +1454,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1470,7 +1470,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! 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=isx,iex GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1486,7 +1486,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1508,7 +1508,7 @@ SUBROUTINE MDL2P(iostatusD3D) if ( log1 ) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = USL(I,J) GRID2(I,J) = VSL(I,J) ENDDO @@ -1534,7 +1534,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1545,7 +1545,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1561,7 +1561,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=isx,iex GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1590,7 +1590,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1603,14 +1603,14 @@ 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=isx,iex EGRID2(I,J) = FSL(I,J)*GI ENDDO ENDDO CALL CALSTRM(EGRID2(1,jsta),EGRID1(1,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(FSL(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J) ELSE @@ -1625,7 +1625,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1639,7 +1639,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(022)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = Q2SL(I,J) ENDDO ENDDO @@ -1650,7 +1650,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1666,7 +1666,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=isx,iex GRID1(I,J) = QW1(I,J) + QI1(I,J) QI1(I,J) = spval ENDDO @@ -1674,7 +1674,7 @@ SUBROUTINE MDL2P(iostatusD3D) ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = QW1(I,J) ENDDO ENDDO @@ -1686,7 +1686,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1700,7 +1700,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=isx,iex GRID1(I,J) = QI1(I,J) ENDDO ENDDO @@ -1711,7 +1711,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1724,7 +1724,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=isx,iex GRID1(I,J) = QR1(I,J) ENDDO ENDDO @@ -1735,7 +1735,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1748,7 +1748,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=isx,iex GRID1(I,J) = QS1(I,J) ENDDO ENDDO @@ -1759,7 +1759,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1772,7 +1772,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=isx,iex GRID1(I,J) = QG1(I,J) ENDDO ENDDO @@ -1783,7 +1783,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1797,7 +1797,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=isx,iex GRID1(I,J) = C1D(I,J) ENDDO ENDDO @@ -1808,7 +1808,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1821,7 +1821,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=isx,iex GRID1(I,J) = FRIME(I,J) ENDDO ENDDO @@ -1832,7 +1832,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1845,7 +1845,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=isx,iex GRID1(I,J) = RAD(I,J) ENDDO ENDDO @@ -1856,7 +1856,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1869,7 +1869,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=isx,iex GRID1(I,J) = DBZ1(I,J) ENDDO ENDDO @@ -1880,7 +1880,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1895,7 +1895,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1906,7 +1906,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1922,7 +1922,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=isx,iex GRID1(I,J) = FSL(I,J)*GI EGRID1(I,J) = SPVAL ENDDO @@ -1932,7 +1932,7 @@ SUBROUTINE MDL2P(iostatusD3D) ,FSL_OLD(1,jsta_2l),EGRID1(1,jsta_2l)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID1(I,J) ! IF(GRID1(I,J) > 3. .OR. GRID1(I,J) < 0.) ! + print*,'bad CAT',i,j,GRID1(I,J) @@ -1945,7 +1945,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1957,7 +1957,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=isx,iex USL_OLD(I,J) = USL(I,J) VSL_OLD(I,J) = VSL(I,J) FSL_OLD(I,J) = FSL(I,J)*GI @@ -1969,7 +1969,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(268)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = O3SL(I,J) ENDDO ENDDO @@ -1982,7 +1982,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1995,7 +1995,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=isx,iex GRID1(I,J) = (1./RD)*SMOKESL(I,J,1)*(SPL(LP)/TSL(I,J)) ENDDO ENDDO @@ -2006,7 +2006,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2019,7 +2019,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(438)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = DUSTSL(I,J,1) ENDDO ENDDO @@ -2030,7 +2030,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2042,7 +2042,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=isx,iex GRID1(I,J) = DUSTSL(I,J,2) ENDDO ENDDO @@ -2053,7 +2053,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2065,7 +2065,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=isx,iex GRID1(I,J) = DUSTSL(I,J,3) ENDDO ENDDO @@ -2076,7 +2076,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2088,7 +2088,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=isx,iex GRID1(I,J) = DUSTSL(I,J,4) ENDDO ENDDO @@ -2099,7 +2099,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2111,7 +2111,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=isx,iex GRID1(I,J) = DUSTSL(I,J,5) ENDDO ENDDO @@ -2122,7 +2122,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2138,7 +2138,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=isx,iex GRID1(I,J) = D3DSL(i,j,1) ENDDO ENDDO @@ -2173,7 +2173,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2185,7 +2185,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=isx,iex GRID1(I,J) = D3DSL(i,j,2) ENDDO ENDDO @@ -2220,7 +2220,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2232,7 +2232,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=isx,iex GRID1(I,J) = D3DSL(i,j,3) ENDDO ENDDO @@ -2267,7 +2267,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2279,7 +2279,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=isx,iex GRID1(I,J) = D3DSL(i,j,4) ENDDO ENDDO @@ -2314,7 +2314,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2326,7 +2326,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=isx,iex GRID1(I,J) = D3DSL(i,j,5) ENDDO ENDDO @@ -2361,7 +2361,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2373,7 +2373,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=isx,iex GRID1(I,J) = D3DSL(i,j,6) ENDDO ENDDO @@ -2408,7 +2408,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2420,7 +2420,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=isx,iex GRID1(I,J) = D3DSL(i,j,7) ENDDO ENDDO @@ -2455,7 +2455,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2467,7 +2467,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=isx,iex GRID1(I,J) = D3DSL(i,j,8) ENDDO ENDDO @@ -2502,7 +2502,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2514,7 +2514,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=isx,iex GRID1(I,J) = D3DSL(i,j,9) ENDDO ENDDO @@ -2549,7 +2549,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2561,7 +2561,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=isx,iex GRID1(I,J) = D3DSL(i,j,10) ENDDO ENDDO @@ -2597,7 +2597,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2609,7 +2609,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=isx,iex GRID1(I,J) = D3DSL(i,j,11) ENDDO ENDDO @@ -2645,7 +2645,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2657,7 +2657,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=isx,iex GRID1(I,J) = D3DSL(i,j,12) ENDDO ENDDO @@ -2693,7 +2693,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2705,7 +2705,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=isx,iex GRID1(I,J) = D3DSL(i,j,13) ENDDO ENDDO @@ -2741,7 +2741,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2753,7 +2753,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=isx,iex GRID1(I,J) = D3DSL(i,j,14) ENDDO ENDDO @@ -2789,7 +2789,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2801,7 +2801,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=isx,iex GRID1(I,J) = D3DSL(i,j,15) ENDDO ENDDO @@ -2837,7 +2837,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2849,7 +2849,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=isx,iex GRID1(I,J) = D3DSL(i,j,16) ENDDO ENDDO @@ -2884,7 +2884,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2896,7 +2896,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=isx,iex GRID1(I,J) = D3DSL(i,j,17) ENDDO ENDDO @@ -2932,7 +2932,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2944,7 +2944,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=isx,iex GRID1(I,J) = D3DSL(i,j,18) ENDDO ENDDO @@ -2980,7 +2980,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2992,7 +2992,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=isx,iex GRID1(I,J) = D3DSL(i,j,19) ENDDO ENDDO @@ -3027,7 +3027,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3039,7 +3039,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=isx,iex GRID1(I,J) = D3DSL(i,j,20) ENDDO ENDDO @@ -3075,7 +3075,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3087,7 +3087,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=isx,iex GRID1(I,J) = D3DSL(i,j,21) ENDDO ENDDO @@ -3123,7 +3123,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3135,7 +3135,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=isx,iex GRID1(I,J) = D3DSL(i,j,22) ENDDO ENDDO @@ -3170,7 +3170,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3182,7 +3182,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=isx,iex 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) & @@ -3223,7 +3223,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3235,7 +3235,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=isx,iex GRID1(I,J) = D3DSL(i,j,23) ENDDO ENDDO @@ -3271,7 +3271,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3283,7 +3283,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=isx,iex GRID1(I,J) = D3DSL(i,j,24) ENDDO ENDDO @@ -3319,7 +3319,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3331,7 +3331,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=isx,iex GRID1(I,J) = D3DSL(i,j,25) ENDDO ENDDO @@ -3367,7 +3367,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3379,7 +3379,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=isx,iex GRID1(I,J) = D3DSL(i,j,26) ENDDO ENDDO @@ -3415,7 +3415,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3427,7 +3427,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=isx,iex GRID1(I,J) = D3DSL(i,j,27) ENDDO ENDDO @@ -3463,7 +3463,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3482,7 +3482,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! print*,'computing dew point for Haine Index at ',SPL(LP) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex HAINES(i,j) = SPVAL EGRID2(I,J) = SPL(LP) ENDDO @@ -3491,7 +3491,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,dum1,ista,imois) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(SM(I,J) < 1.0 .AND. ZINT(I,J,LM+1) < FSL(I,J)*GI) THEN DUM1 = TSL(I,J)-TPRS(I,J,LUHI) IF(DUM1 <= 17.)THEN @@ -3523,7 +3523,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! print*,'computing dew point for Haine Index at ',SPL(LP) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EGRID2(I,J) = SPL(LP) ENDDO ENDDO @@ -3531,7 +3531,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,dum1,ista,imois) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(SM(I,J) < 1.0 .AND. ZINT(I,J,LM+1) < FSL(I,J)*GI) THEN DUM1 = TSL(I,J)-TPRS(I,J,LUHI) IF(DUM1 <=5. ) THEN @@ -3563,7 +3563,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! print*,'computing dew point for Haine Index at ',SPL(LP) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EGRID2(I,J)=SPL(LP) ENDDO ENDDO @@ -3571,7 +3571,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,dum1,ista,imois) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(SM(I,J) < 1.0 .AND. ZINT(I,J,LM+1) < FSL(I,J)*GI) THEN DUM1 = TSL(I,J)-TPRS(I,J,LUHI) IF(DUM1 <= 3.)THEN @@ -3602,7 +3602,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = HAINES(i,jj) enddo enddo @@ -3624,7 +3624,7 @@ SUBROUTINE MDL2P(iostatusD3D) LP=46 ! 1000 MB !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = W_UP_MAX(I,J) ! print *,' writing w_up_max, i,j, = ', w_up_max(i,j) ENDDO @@ -3642,7 +3642,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3655,7 +3655,7 @@ SUBROUTINE MDL2P(iostatusD3D) LP = 46 ! 1000 MB !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = W_DN_MAX(I,J) ENDDO ENDDO @@ -3672,7 +3672,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3690,7 +3690,7 @@ SUBROUTINE MDL2P(iostatusD3D) LP = 46 ! 1000 MB !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = W_MEAN(I,J) ENDDO ENDDO @@ -3707,7 +3707,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3733,7 +3733,7 @@ SUBROUTINE MDL2P(iostatusD3D) END IF !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = PSLP(I,J) ENDDO ENDDO @@ -3745,7 +3745,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3758,7 +3758,7 @@ SUBROUTINE MDL2P(iostatusD3D) CALL MAPSSLP(TPRS) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = PSLP(I,J) ENDDO ENDDO @@ -3768,7 +3768,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3790,14 +3790,14 @@ 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=isx,iex GRID1(I,J) = FSL(I,J)*GI ENDDO ENDDO ELSE !$omp parallel do private(i,j,PSLPIJ,ALPSL,PSFC) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(PSLP(I,J) < spval) THEN PSLPIJ = PSLP(I,J) ALPSL = LOG(PSLPIJ) @@ -3830,7 +3830,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo diff --git a/sorc/ncep_post.fd/MDL2SIGMA.f b/sorc/ncep_post.fd/MDL2SIGMA.f index 1e4b35fe6..fa0e5a972 100644 --- a/sorc/ncep_post.fd/MDL2SIGMA.f +++ b/sorc/ncep_post.fd/MDL2SIGMA.f @@ -61,7 +61,7 @@ SUBROUTINE MDL2SIGMA h1m12, d00, h2, rd, g, gi, h99999 use ctlblk_mod, only: jsta_2l, jend_2u, spval, lp1, jsta, jend, lm, & grib, cfld, datapd, fld_info, me, jend_m, im, & - jm, im_jm + jm, im_jm,isx,iex use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml use gridspec_mod, only :gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -79,7 +79,8 @@ SUBROUTINE MDL2SIGMA LOGICAL READTHK LOGICAL IOOMG,IOALL LOGICAL DONEFSL1,TSLDONE - real, dimension(im,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL, Q2SL, & +! real, dimension(im,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL, Q2SL, & + real, dimension(isx:iex,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL, Q2SL, & FSL1, CFRSIG, EGRID1, EGRID2 REAL GRID1(IM,JM),GRID2(IM,JM) REAL SIGO(LSIG+1),DSIGO(LSIG),ASIGO(LSIG) @@ -95,7 +96,7 @@ SUBROUTINE MDL2SIGMA ! QR1 - rain mixing ratio ! QS1 - snow mixing ratio ! - real, dimension(im,jsta_2l:jend_2u) :: C1D, QW1, QI1, QR1, QS1, QG1, AKH + real, dimension(isx:iex,jsta_2l:jend_2u) :: C1D, QW1, QI1, QR1, QS1, QG1, AKH ! integer I,J,L,LL,LP,LLMH,II,JJ,JJB,JJE,NHOLD real PFSIGO,APFSIGO,PSIGO,APSIGO,PNL1,PU,ZU,TU,QU,QSAT, & @@ -193,7 +194,7 @@ SUBROUTINE MDL2SIGMA END IF ! OBTAIN GEOPOTENTIAL AT 1ST LEVEL DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=isx,iex FSL(I,J)=SPVAL AKH(I,J)=SPVAL NL1XF(I,J)=LP1 @@ -205,7 +206,7 @@ SUBROUTINE MDL2SIGMA END DO END DO DO 167 J=JSTA,JEND - DO 167 I=1,IM + DO 167 I=isx,iex DONEFSL1=.FALSE. PFSIGO=PTSIGO APFSIGO=LOG(PFSIGO) @@ -306,7 +307,7 @@ SUBROUTINE MDL2SIGMA IF (LVLS(1,IGET(205))>0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(FSL1(I,J)0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex 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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif if(me==0)print*,'output Heat Diffusivity' @@ -350,7 +351,7 @@ SUBROUTINE MDL2SIGMA NHOLD=0 ! DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=isx,iex ! TSL(I,J)=SPVAL @@ -404,7 +405,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=isx,iex LL=NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -552,7 +553,7 @@ SUBROUTINE MDL2SIGMA ! ! OBTAIN GEOPOTENTIAL AND KH ON INTERFACES DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=isx,iex FSL(I,J)=SPVAL AKH(I,J)=SPVAL NL1XF(I,J)=LP1 @@ -568,7 +569,7 @@ SUBROUTINE MDL2SIGMA ! ! DO J=JSTA_2L,JEND_2U DO J=JSTA,JEND ! Moorthi on 26 Nov 2014 - DO I=1,IM + DO I=isx,iex DONEFSL1=.FALSE. TSLDONE=.FALSE. LLMH = NINT(LMH(I,J)) @@ -718,10 +719,10 @@ 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(isx:iex,JSTA_2L:JEND_2U,LP1)) IF(gridtype=='E')THEN DO J=JSTA,JEND - DO I=1,IM-MOD(J,2) + DO I=isx,iex-MOD(J,2) ! !*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. @@ -763,7 +764,7 @@ SUBROUTINE MDL2SIGMA ENDDO ! DO 230 J=JSTA,JEND - DO 230 I=1,IM-MOD(j,2) + DO 230 I=isx,iex-MOD(j,2) LLMH = NINT(LMH(I,J)) IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC PDV=0.5*(PINT(I,J,LLMH+1)+PINT(I+1,J,LLMH+1)) @@ -826,7 +827,7 @@ SUBROUTINE MDL2SIGMA ELSE IF (gridtype=='B')THEN DO J=JSTA,JEND_M - DO I=1,IM-1 + DO I=isx,iex-1 ! !*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. @@ -855,7 +856,7 @@ SUBROUTINE MDL2SIGMA ENDDO ! DO 231 J=JSTA,JEND_M - DO 231 I=1,IM-1 + DO 231 I=isx,iex-1 PDV=0.25*(PINT(I,J,LP1)+PINT(I+1,J,LP1) & +PINT(I,J+1,LP1)+PINT(I+1,J+1,LP1)) PSIGO=PTSIGO+ASIGO(LP)*(PDV-PTSIGO) @@ -926,7 +927,7 @@ SUBROUTINE MDL2SIGMA IF(LVLS(LP+1,IGET(205))>0)THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(FSL(I,J)0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=AKH(I,J) IF(LP==(LSIG+1))GRID1(I,J)=0.0 !! NO SLIP ASSUMTION FOR CMAQ ENDDO @@ -959,7 +960,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif if(me==0)print*,'output Heat Diffusivity' ENDIF @@ -970,7 +971,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=isx,iex GRID1(I,J)=TSL(I,J) ENDDO ENDDO @@ -978,7 +979,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif ENDIF ENDIF @@ -989,7 +990,7 @@ SUBROUTINE MDL2SIGMA IF(LVLS(LP,IGET(216))>0)THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex LLMH = NINT(LMH(I,J)) GRID1(I,J)=PTSIGO+ASIGO(LP)*(PINT(I,J,LLMH+1)-PTSIGO) ENDDO @@ -998,7 +999,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif ENDIF ENDIF @@ -1008,7 +1009,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=isx,iex GRID1(I,J)=QSL(I,J) ENDDO ENDDO @@ -1017,7 +1018,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif ENDIF ENDIF @@ -1027,7 +1028,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=isx,iex GRID1(I,J)=OSL(I,J) ENDDO ENDDO @@ -1035,7 +1036,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif ENDIF ENDIF @@ -1045,7 +1046,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=isx,iex GRID1(I,J)=USL(I,J) GRID2(I,J)=VSL(I,J) ENDDO @@ -1054,11 +1055,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif ENDIF ENDIF @@ -1068,7 +1069,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=isx,iex GRID1(I,J)=Q2SL(I,J) ENDDO ENDDO @@ -1076,7 +1077,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif ENDIF ENDIF @@ -1086,7 +1087,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=isx,iex GRID1(I,J)=QW1(I,J) ENDDO ENDDO @@ -1094,7 +1095,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif ENDIF ENDIF @@ -1104,7 +1105,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=isx,iex GRID1(I,J)=QI1(I,J) ENDDO ENDDO @@ -1112,7 +1113,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif ENDIF ENDIF @@ -1121,7 +1122,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=isx,iex GRID1(I,J)=QR1(I,J) ENDDO ENDDO @@ -1129,7 +1130,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif ENDIF ENDIF @@ -1138,7 +1139,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=isx,iex GRID1(I,J)=QS1(I,J) ENDDO ENDDO @@ -1146,7 +1147,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif ENDIF ENDIF @@ -1155,7 +1156,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=isx,iex GRID1(I,J)=QG1(I,J) ENDDO ENDDO @@ -1163,7 +1164,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif ENDIF ENDIF @@ -1172,7 +1173,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=isx,iex GRID1(I,J)=C1D(I,J) ENDDO ENDDO @@ -1180,7 +1181,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif ENDIF ENDIF @@ -1189,7 +1190,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=isx,iex GRID1(I,J)=CFRSIG(I,J) ENDDO ENDDO @@ -1197,7 +1198,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) endif ENDIF ENDIF diff --git a/sorc/ncep_post.fd/MDL2SIGMA2.f b/sorc/ncep_post.fd/MDL2SIGMA2.f index 9ca042a7a..f1449b17d 100644 --- a/sorc/ncep_post.fd/MDL2SIGMA2.f +++ b/sorc/ncep_post.fd/MDL2SIGMA2.f @@ -48,7 +48,7 @@ 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,isx,iex use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml ! implicit none @@ -59,12 +59,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(isx:iex,jsta_2l:jend_2u) :: TSL REAL,dimension(im,jm) :: 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(isx:iex,jsta_2l:jend_2u) :: NL1X ! ! !--- Definition of the following 2D (horizontal) dummy variables @@ -132,7 +132,7 @@ SUBROUTINE MDL2SIGMA2 NHOLD=0 ! DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=isx,iex ! TSL(I,J)=SPVAL @@ -173,7 +173,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=isx,iex LL=NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -261,7 +261,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=isx,iex GRID1(I,J)=TSL(I,J) ENDDO ENDDO diff --git a/sorc/ncep_post.fd/MDLFLD.f b/sorc/ncep_post.fd/MDLFLD.f index 6d1548455..d464939f3 100644 --- a/sorc/ncep_post.fd/MDLFLD.f +++ b/sorc/ncep_post.fd/MDLFLD.f @@ -95,7 +95,7 @@ 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 + me, dt, avrain, theat, ifhr, ifmin, avcnvc, lp1, im, jm,isx,iex use rqstfld_mod, only: iget, id, lvls, iavblfld, lvlsxml use gridspec_mod, only: gridtype,maptype,dxval use upp_physics, only: CALRH, CALCAPE @@ -127,7 +127,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(isx:iex,jsta_2l:jend_2u) :: EGRID1, EGRID2, EGRID3, EGRID4, EGRID5,& EL0, P1D, T1D, Q1D, C1D, & FI1D, FR1D, FS1D, QW1, QI1, & QR1, QS1, CUREFL_S, & @@ -158,10 +158,11 @@ 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(isx:iex,jsta:jend) :: dummy, cape, cin + integer idummy(isx:iex,jsta:jend) real, PARAMETER :: ZSL=0.0, TAUCR=RD*GI*290.66, CONST=0.005*G/RD, GORD=G/RD + logical, parameter :: debugprint = .false. GAMS = 0.0065 GAMD = 0.0100 @@ -183,7 +184,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=isx,iex IF(ABS(REF_10CM(I,J,L)-SPVAL)>SMALL) THEN Model_Radar=.True. exit check_ref @@ -191,18 +192,18 @@ SUBROUTINE MDLFLD ENDDO ENDDO ENDDO check_ref - if(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)) + 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 (isx:iex,JSTA_2L:JEND_2U,LM)) + ALLOCATE(RICHNO (isx:iex,JSTA_2L:JEND_2U,LM)) + ALLOCATE(PBLRI (isx:iex,JSTA_2L:JEND_2U)) ! ! SECOND, STANDARD NGM SEA LEVEL PRESSURE. IF (IGET(105) > 0) THEN CALL NGMSLP !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = SLP(I,J) ENDDO ENDDO @@ -212,7 +213,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -228,7 +229,7 @@ SUBROUTINE MDLFLD ! print*,'DTQ2 in MDLFLD= ',DTQ2 RDTPHS=24.*3.6E6/DTQ2 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF ((HBOT(I,J)-HTOP(I,J)) <= 1.0) THEN ICBOT(I,J)=0 ICTOP(I,J)=0 @@ -256,7 +257,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=isx,iex ENDDO !--- DO J=JSTA,JEND ENDIF !-- IF (MODELNAME=='NMM' .OR. imp_physics==5) THEN ! @@ -274,7 +275,7 @@ SUBROUTINE MDLFLD .or. NMM_GFSmicro)THEN RDTPHS=3.6E6/DTQ2 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex 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 @@ -310,7 +311,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=isx,iex P1D(I,J)=PMID(I,J,L) T1D(I,J)=T(I,J,L) Q1D(I,J)=Q(I,J,L) @@ -363,7 +364,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=isx,iex ze_nc=10.**(0.1*REF_10CM(I,J,L)) DBZ1(I,J)=10.*LOG10(max(Zmin,(ze_nc+CUREFL(I,J)))) DBZR1(I,J)=MIN(DBZR1(I,J), REF_10CM(I,J,L)) @@ -425,7 +426,7 @@ SUBROUTINE MDLFLD !--- This branch is executed if GFS micro (imp_physics=9) is run in the NMM. ! DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex QI1(I,J)=C1D(I,J)*FI1D(I,J) QW1(I,J)=C1D(I,J)-QI1(I,J) QR1(I,J)=D00 @@ -438,7 +439,7 @@ SUBROUTINE MDLFLD ENDDO ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex LLMH = NINT(LMH(I,J)) IF (L > LLMH) THEN QQW(I,J,L) = D00 @@ -468,7 +469,7 @@ SUBROUTINE MDLFLD ENDDO !-- End DO L loop END IF ! end of icount_calmict icount_calmict=icount_calmict+1 - if(me==0)print*,'debug calmict:icount_calmict= ',icount_calmict + if(debugprint .and. me==0)print*,'debug calmict:icount_calmict= ',icount_calmict ! Chuang: add the option to compute individual microphysics species ! for NMMB+Zhao and NMMB+WSM6 which are two of SREF members. @@ -480,7 +481,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=isx,iex LLMH = NINT(LMH(I,J)) IF (L > LLMH) THEN QQW(I,J,L) = D00 @@ -508,7 +509,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=isx,iex LLMH = NINT(LMH(I,J)) IF (L > LLMH) THEN QQW(I,J,L)=D00 @@ -548,7 +549,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=isx,iex DBZ(I,J,L)=REF_10CM(I,J,L) ENDDO ENDDO @@ -556,13 +557,13 @@ 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=isx,iex DBZ(I,J,L)=SPVAL ENDDO ENDDO ENDDO ELSE ! compute radar refl for other than NAM/Ferrier or GFS/Zhao microphysics - if(me==0)print*,'calculating radar ref for non-Ferrier/non-Zhao schemes' + if(debugprint .and. me==0)print*,'calculating radar ref for non-Ferrier/non-Zhao schemes' ! Determine IICE FLAG IF(IMP_PHYSICS == 1 .OR. IMP_PHYSICS == 3)THEN IICE = 0 @@ -574,7 +575,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=isx,iex 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 @@ -603,10 +604,10 @@ SUBROUTINE MDLFLD IF(IMP_PHYSICS /= 8 .AND. IMP_PHYSICS /= 9 .and. IMP_PHYSICS /= 28) THEN !tgs - non-Thompson schemes -!$omp parallel do private(i,j,l,dens,llmh) +!$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=isx,iex !--- Estimate radar reflectivity factor from convection at level L ! CUREFL(I,J)=0. @@ -716,7 +717,7 @@ SUBROUTINE MDLFLD ze_gmax = -1.E30 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex refl(i,j) = -10. ze_max = -10. @@ -859,7 +860,7 @@ SUBROUTINE MDLFLD ! ABSOLUTE VORTICITY ON MDL SURFACES. ! ! - allocate (RH3D(im,jsta_2l:jend_2u,lm)) + allocate (RH3D(isx:iex,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. & @@ -894,7 +895,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = PMID(I,J,LL) ENDDO ENDDO @@ -905,7 +906,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -921,7 +922,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = QQW(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -933,7 +934,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -948,7 +949,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j,jj) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = QQI(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -960,7 +961,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -975,7 +976,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = QQR(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -987,7 +988,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1002,7 +1003,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = QQS(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -1014,7 +1015,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1029,7 +1030,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex if(QQG(I,J,LL) < 1.e-12) QQG(I,J,LL) = 0. !tgs GRID1(I,J) = QQG(I,J,LL) ENDDO @@ -1041,7 +1042,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1056,7 +1057,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex if(QQNW(I,J,LL) < 1.e-8) QQNW(I,J,LL) = 0. !tgs GRID1(I,J) = QQNW(I,J,LL) ENDDO @@ -1068,7 +1069,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1083,7 +1084,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex if(QQNI(I,J,LL) < 1.e-8) QQNI(I,J,LL) = 0. !tgs GRID1(I,J) = QQNI(I,J,LL) ENDDO @@ -1095,7 +1096,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1110,7 +1111,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex if(QQNR(I,J,LL) < 1.e-8) QQNR(I,J,LL) = 0. !tgs GRID1(I,J) = QQNR(I,J,LL) ENDDO @@ -1122,7 +1123,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1135,7 +1136,7 @@ SUBROUTINE MDLFLD IF (LVLS(L,IGET(766)) > 0)THEN LL=LM-L+1 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex if(QQNWFA(I,J,LL)<1.e-8)QQNWFA(I,J,LL)=0. !tgs GRID1(I,J)=QQNWFA(I,J,LL) ENDDO @@ -1155,7 +1156,7 @@ SUBROUTINE MDLFLD IF (LVLS(L,IGET(767)) > 0)THEN LL=LM-L+1 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex if(QQNIFA(I,J,LL)<1.e-8)QQNIFA(I,J,LL)=0. !tgs GRID1(I,J)=QQNIFA(I,J,LL) ENDDO @@ -1176,7 +1177,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(abs(CFR(I,J,LL)-SPVAL) > SMALL) & & GRID1(I,J) = CFR(I,J,LL)*H100 ENDDO @@ -1189,7 +1190,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1204,7 +1205,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(MODELNAME == 'RAPR') THEN GRID1(I,J) = CFR(I,J,LL) ELSE @@ -1219,7 +1220,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1243,14 +1244,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=isx,iex 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=isx,iex GRID1(I,J) = DBZ(I,J,LL) ENDDO ENDDO @@ -1264,7 +1265,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1280,7 +1281,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = CWM(I,J,LL) ENDDO ENDDO @@ -1291,7 +1292,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1306,7 +1307,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = F_rain(I,J,LL) ENDDO ENDDO @@ -1317,7 +1318,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1332,7 +1333,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = F_ice(I,J,LL) ENDDO ENDDO @@ -1343,7 +1344,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1359,7 +1360,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = F_RimeF(I,J,LL) ENDDO ENDDO @@ -1370,7 +1371,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1385,7 +1386,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = ZMID(I,J,LL) ENDDO ENDDO @@ -1396,7 +1397,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1411,7 +1412,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = T(I,J,LL) ENDDO ENDDO @@ -1422,7 +1423,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1437,7 +1438,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=T(I,J,LL)*(1.+D608*Q(I,J,LL)) ENDDO ENDDO @@ -1457,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=isx,iex P1D(I,J) = PMID(I,J,LL) T1D(I,J) = T(I,J,LL) ENDDO @@ -1466,7 +1467,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -1477,7 +1478,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1492,7 +1493,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex P1D(I,J) = PMID(I,J,LL) T1D(I,J) = T(I,J,LL) ENDDO @@ -1501,7 +1502,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID3(I,J) * (1.+D608*Q(I,J,LL)) ENDDO ENDDO @@ -1512,7 +1513,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1528,7 +1529,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex P1D(I,J) = PMID(I,J,LL) T1D(I,J) = T(I,J,LL) Q1D(I,J) = Q(I,J,LL) @@ -1539,7 +1540,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID4(I,J)*100. RH3D(I,J,LL) = GRID1(I,J) EGRID2(I,J) = Q(I,J,LL)/max(1.e-8,EGRID4(I,J)) ! Revert QS to compute cloud cover later @@ -1553,7 +1554,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1568,7 +1569,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex P1D(I,J) = PMID(I,J,LL) T1D(I,J) = T(I,J,LL) Q1D(I,J) = Q(I,J,LL) @@ -1577,7 +1578,7 @@ SUBROUTINE MDLFLD CALL CALDWP(P1D(1,jsta),Q1D(1,jsta),EGRID3(1,jsta),T1D(1,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -1588,7 +1589,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1602,7 +1603,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = Q(I,J,LL) ENDDO ENDDO @@ -1614,7 +1615,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1628,7 +1629,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = Q(I,J,LL) / (1.-Q(I,J,LL)) ENDDO ENDDO @@ -1640,7 +1641,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1657,7 +1658,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=isx,iex Q1D(I,J) = Q(I,J,LL) EGRID1(I,J) = UH(I,J,LL) EGRID2(I,J) = VH(I,J,LL) @@ -1666,7 +1667,7 @@ SUBROUTINE MDLFLD CALL CALMCVG(Q1D,EGRID1,EGRID2,EGRID3) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID3(I,J) MCVG(I,J,LL) = EGRID3(I,J) ENDDO @@ -1679,7 +1680,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1695,7 +1696,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = UH(I,J,LL) GRID2(I,J) = VH(I,J,LL) ENDDO @@ -1707,7 +1708,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1717,7 +1718,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1731,7 +1732,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = OMGA(I,J,LL) ENDDO ENDDO @@ -1742,7 +1743,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1756,7 +1757,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=WH(I,J,LL) ENDDO ENDDO @@ -1767,7 +1768,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1781,7 +1782,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=isx,iex EGRID1(I,J) = UH(I,J,LL) EGRID2(I,J) = VH(I,J,LL) ENDDO @@ -1789,7 +1790,7 @@ SUBROUTINE MDLFLD CALL CALVOR(EGRID1,EGRID2,EGRID3) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -1800,7 +1801,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1814,14 +1815,14 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EGRID1(I,J) = ZMID(I,J,LL) ENDDO ENDDO CALL CALSTRM(EGRID1(1,jsta),EGRID2(1,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID2(I,J) ENDDO ENDDO @@ -1832,7 +1833,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1846,7 +1847,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = Q2(I,J,LL) ENDDO ENDDO @@ -1857,7 +1858,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1869,14 +1870,14 @@ SUBROUTINE MDLFLD !HC IF (IGET(124)>0) THEN !HC IF (LVLS(L,IGET(124))>0) THEN !HC DO J=JSTA,JEND -!HC DO I=1,IM +!HC DO I=isx,iex !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,GRIDisx,iex,JM) !HC ENDIF !HC ENDIF ! @@ -1885,12 +1886,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=isx,iex ! 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,GRIDisx,iex,JM) ! ENDIF ! ENDIF ! @@ -1900,12 +1901,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=isx,iex ! 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,GRIDisx,iex,JM) ! ENDIF ! ENDIF ! @@ -1916,7 +1917,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = TTND(I,J,LL) ENDDO ENDDO @@ -1927,7 +1928,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1942,7 +1943,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RSWTT(I,J,LL) ENDDO ENDDO @@ -1953,7 +1954,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1968,7 +1969,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RLWTT(I,J,LL) ENDDO ENDDO @@ -1979,7 +1980,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2001,7 +2002,7 @@ SUBROUTINE MDLFLD ENDIF !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = TRAIN(I,J,LL)*RRNUM ENDDO ENDDO @@ -2034,7 +2035,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2053,7 +2054,7 @@ SUBROUTINE MDLFLD ENDIF !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = TCUCN(I,J,LL)*RRNUM ENDDO ENDDO @@ -2086,7 +2087,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2100,7 +2101,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = O3(I,J,LL) ENDDO ENDDO @@ -2111,7 +2112,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2126,7 +2127,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = (1./RD)*(PMID(I,J,LL)/T(I,J,LL))*SMOKE(I,J,LL,1) ENDDO ENDDO @@ -2137,7 +2138,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2151,7 +2152,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex !GRID1(I,J) = DUST(I,J,LL,1) GRID1(I,J) = DUST(I,J,LL,1)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO @@ -2163,7 +2164,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2177,7 +2178,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex !GRID1(I,J) = DUST(I,J,LL,2) GRID1(I,J) = DUST(I,J,LL,2)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO @@ -2189,7 +2190,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2203,7 +2204,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex !GRID1(I,J) = DUST(I,J,LL,3) GRID1(I,J) = DUST(I,J,LL,3)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO @@ -2215,7 +2216,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2229,7 +2230,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex !GRID1(I,J) = DUST(I,J,LL,4) GRID1(I,J) = DUST(I,J,LL,4)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO @@ -2241,7 +2242,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2255,7 +2256,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex !GRID1(I,J) = DUST(I,J,LL,5) GRID1(I,J) = DUST(I,J,LL,5)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO @@ -2267,7 +2268,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2281,7 +2282,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = SALT(I,J,LL,1)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO ENDDO @@ -2292,7 +2293,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2306,7 +2307,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = SALT(I,J,LL,2)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO ENDDO @@ -2317,7 +2318,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2331,7 +2332,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = SALT(I,J,LL,3)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO ENDDO @@ -2342,7 +2343,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2356,7 +2357,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = SALT(I,J,LL,4)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO ENDDO @@ -2367,7 +2368,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2381,7 +2382,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = SALT(I,J,LL,5)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO ENDDO @@ -2392,7 +2393,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2406,7 +2407,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex !GRID1(I,J) = SUSO(I,J,LL,1) GRID1(I,J) = SUSO(I,J,LL,1)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO @@ -2418,7 +2419,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2432,7 +2433,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex !GRID1(I,J) = WASO(I,J,LL,1) GRID1(I,J) = WASO(I,J,LL,1)*RHOMID(I,J,LL) !lzhang ENDDO @@ -2444,7 +2445,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2458,7 +2459,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex !GRID1(I,J) = WASO(I,J,LL,2) GRID1(I,J) = WASO(I,J,LL,2)*RHOMID(I,J,LL) !lzhang ENDDO @@ -2470,7 +2471,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2484,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=isx,iex !GRID1(I,J) = SOOT(I,J,LL,1) GRID1(I,J) = SOOT(I,J,LL,1)*RHOMID(I,J,LL) !lzhang ENDDO @@ -2496,7 +2497,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2510,7 +2511,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex !GRID1(I,J) = SOOT(I,J,LL,2) GRID1(I,J) = SOOT(I,J,LL,2)*RHOMID(I,J,LL) !lzhang ENDDO @@ -2522,7 +2523,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2536,7 +2537,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RHOMID(I,J,LL) ENDDO ENDDO @@ -2547,7 +2548,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2561,7 +2562,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = DPRES(I,J,LL) ENDDO ENDDO @@ -2572,7 +2573,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2600,7 +2601,7 @@ SUBROUTINE MDLFLD !MEB Eta-specific code ! NEED TO CALCULATE RAIN WATER AND SNOW MIXING RATIOS ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=isx,iex !MEB IF (PREC(I,J)==0) THEN !MEB QSNO(I,J)=0. !MEB QRAIN(I,J)=0. @@ -2629,13 +2630,13 @@ SUBROUTINE MDLFLD ! ENDDO ! CALL CALVIS(QV,QCD,QRAIN1,QICE1,QSNO1,TT,PPP,VIS) ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=isx,iex ! GRID1(I,J)=VIS(I,J) ! ENDDO ! ENDDO ! ID(1:25) = 0 ! CALL GRIBIT(IGET(180),LVLS(1,IGET(180)), -! X GRID1,IM,JM) +! X GRIDisx,iex,JM) ! ENDIF ! ! INSTANTANEOUS CONVECTIVE PRECIPITATION RATE. @@ -2643,13 +2644,13 @@ SUBROUTINE MDLFLD ! IF (IGET(249)>0) THEN ! RDTPHS=1000./DTQ2 ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=isx,iex ! 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,GRIDisx,iex,JM) ! ENDIF ! ! COMPOSITE RADAR REFLECTIVITY (maximum dBZ in each column) @@ -2658,7 +2659,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=isx,iex GRID1(I,J) = DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J) = MAX( GRID1(I,J), DBZ(I,J,L) ) @@ -2678,7 +2679,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=isx,iex GRID1(I,J) = DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J) = MAX( GRID1(I,J), REF_10CM(I,J,L) ) @@ -2688,7 +2689,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = REFC_10CM(I,J) ENDDO ENDDO @@ -2697,7 +2698,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = refl(i,j) ENDDO ENDDO @@ -2710,7 +2711,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2722,7 +2723,7 @@ SUBROUTINE MDLFLD ! on emprical conversion factors (0.00344) IF (IGET(581)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=0.0 DO L=1,NINT(LMH(I,J)) if(zint(i,j,l) < spval) then @@ -2738,7 +2739,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2749,7 +2750,7 @@ SUBROUTINE MDLFLD ! IF (IGET(276)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J)=MAX( GRID1(I,J), DBZR(I,J,L) ) @@ -2762,7 +2763,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2774,7 +2775,7 @@ SUBROUTINE MDLFLD ! IF (IGET(277)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J)=MAX( GRID1(I,J), DBZI(I,J,L) ) @@ -2787,7 +2788,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2801,7 +2802,7 @@ SUBROUTINE MDLFLD ! IF (IGET(278)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J)=MAX( GRID1(I,J), DBZC(I,J,L) ) @@ -2814,7 +2815,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2827,7 +2828,7 @@ SUBROUTINE MDLFLD IF (IGET(426)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=0.0 DO L=1,NINT(LMH(I,J)) IF (DBZ(I,J,L)>=18.0) THEN @@ -2843,7 +2844,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2862,7 +2863,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=isx,iex GRID1(I,J) = -999. DO L=1,NINT(LMH(I,J)) IF (REF_10CM(I,J,L)>=18.0) THEN @@ -2891,7 +2892,7 @@ SUBROUTINE MDLFLD ENDDO ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = -999. DO L=1,NINT(LMH(I,J)) IF (DBZ(I,J,L) >= 18.0) THEN @@ -2908,7 +2909,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2919,7 +2920,7 @@ SUBROUTINE MDLFLD ! IF (IGET(769)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=0.0 DO L=1,NINT(LMH(I,J)) GRID1(I,J)=GRID1(I,J) + (QQR(I,J,L) + & @@ -2935,7 +2936,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2949,7 +2950,7 @@ SUBROUTINE MDLFLD IF (IGET(770) > 0) THEN IF(MODELNAME == 'RAPR' .AND. (IMP_PHYSICS == 8 .or. IMP_PHYSICS == 28)) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = 0.0 DO L=1,NINT(LMH(I,J)) IF (REF_10CM(I,J,L) > -10.0 ) THEN @@ -2962,7 +2963,7 @@ SUBROUTINE MDLFLD ENDDO ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = 0.0 DO L=1,NINT(LMH(I,J)) GRID1(I,J) = GRID1(I,J) + 0.00344 * & @@ -2978,7 +2979,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2995,7 +2996,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=isx,iex LLMH=NINT(LMH(I,J)) Q1D(I,J)=Q(I,J,LLMH) if(Q1D(I,J)<=0.) Q1D(I,J)=0. !tgs @@ -3074,7 +3075,7 @@ SUBROUTINE MDLFLD ! DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(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) @@ -3095,7 +3096,7 @@ SUBROUTINE MDLFLD IF (IGET(410)>0) THEN CALL CALVIS_GSD(CZEN,VIS) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=VIS(I,J) END DO END DO @@ -3118,7 +3119,7 @@ SUBROUTINE MDLFLD GRID1 = -20.0 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = REF1KM_10CM(I,J) END DO END DO @@ -3126,13 +3127,13 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = refl1km(I,J) END DO END DO ENDIF ! CRA - print *,'MAX/MIN radar reflct - 1km ',maxval(grid1),minval(grid1) +! print *,'MAX/MIN radar reflct - 1km ',maxval(grid1),minval(grid1) if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(748)) @@ -3152,7 +3153,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=isx,iex GRID1(I,J) = REF4KM_10CM(I,J) END DO END DO @@ -3160,13 +3161,13 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = refl4km(I,J) END DO END DO ENDIF ! CRA - print *,'MAX/MIN radar reflct - 4km ',maxval(grid1),minval(grid1) +! print *,'MAX/MIN radar reflct - 4km ',maxval(grid1),minval(grid1) if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(757)) @@ -3179,7 +3180,7 @@ SUBROUTINE MDLFLD IF (IGET(912)>0) THEN Zm10c=spval DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ! dong handle missing value if (slp(i,j) < spval) then Zm10c(I,J)=ZMID(I,J,NINT(LMH(I,J))) @@ -3203,7 +3204,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=isx,iex GRID1(I,J)=spval ! dong handle missing value if (slp(i,j) < spval) then @@ -3214,7 +3215,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=spval ! dong handle missing value if (slp(i,j) < spval) then @@ -3247,7 +3248,7 @@ SUBROUTINE MDLFLD IF (IGET(147)>0) THEN ! DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EL0(I,J) ENDDO ENDDO @@ -3267,7 +3268,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,l) DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EL(I,J,L) = D00 ENDDO ENDDO @@ -3278,7 +3279,7 @@ SUBROUTINE MDLFLD ELSE IF(MODELNAME == 'NMM')THEN DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EL(I,J,L)=EL_PBL(I,J,L) !NOW EL COMES OUT OF WRF NMM ENDDO ENDDO @@ -3301,7 +3302,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EL(I,J,LL) ENDDO ENDDO @@ -3312,7 +3313,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3328,7 +3329,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RICHNO(I,J,LL) ENDDO ENDDO @@ -3339,7 +3340,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3372,7 +3373,7 @@ SUBROUTINE MDLFLD IF (IGET(289) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = PBLRI(I,J) ! PBLH(I,J) = PBLRI(I,J) ENDDO @@ -3383,7 +3384,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3397,7 +3398,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=isx,iex EGRID3(I,J) = PBLRI(I,J) + ZINT(I,J,LM+1) END DO END DO @@ -3405,7 +3406,7 @@ SUBROUTINE MDLFLD CALL H2U(EGRID3(1:im,JSTA_2L:JEND_2U),EGRID4) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EGRID1(I,J) = 0.0 EGRID2(I,J) = 0.0 END DO @@ -3416,7 +3417,7 @@ SUBROUTINE MDLFLD CALL H2U(PINT(1:IM,JSTA_2L:JEND_2U,L), EGRID7) HCOUNT=0 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex if (EGRID5(I,J) <= EGRID4(I,J)) then ! if (I == 50 .and. J == 50) then @@ -3435,7 +3436,7 @@ SUBROUTINE MDLFLD ENDDO vert_loopu !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(EGRID2(I,J) > 0.)THEN GRID1(I,J) = EGRID1(I,J)/EGRID2(I,J) ELSE @@ -3447,7 +3448,7 @@ SUBROUTINE MDLFLD CALL H2V(EGRID3(1:im,JSTA_2L:JEND_2U),EGRID4) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EGRID1(i,j) = 0. EGRID2(i,j) = 0. EGRID5(i,j) = 0. @@ -3461,7 +3462,7 @@ SUBROUTINE MDLFLD CALL H2V(PINT(1:IM,JSTA_2L:JEND_2U,L), EGRID7) HCOUNT=0 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex if (EGRID5(I,J) <= EGRID4(I,J)) then HCOUNT=HCOUNT+1 DP = EGRID6(I,J) - EGRID7(I,J) @@ -3476,7 +3477,7 @@ SUBROUTINE MDLFLD ENDDO vert_loopv !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(EGRID2(I,J) > 0.)THEN GRID2(I,J) = EGRID1(I,J)/EGRID2(I,J) ELSE @@ -3490,7 +3491,7 @@ SUBROUTINE MDLFLD CALL V2H(GRID2(1,JSTA_2L),EGRID2) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ! EGRID1 is transport wind speed ! prevent floating overflow if either component is undefined @@ -3515,7 +3516,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3524,7 +3525,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -3542,7 +3543,7 @@ SUBROUTINE MDLFLD ! write(0,*) 'IM is: ', IM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF (PBLRI(I,J) /= SPVAL .and. EGRID3(I,J)/=SPVAL) then GRID1(I,J) = EGRID3(I,J)*PBLRI(I,J) @@ -3565,7 +3566,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3588,7 +3589,7 @@ SUBROUTINE MDLFLD if(grib == 'grib2')then dxm=dxm/1000.0 endif - if(me==0)print *,'dxm=',dxm +! if(me==0)print *,'dxm=',dxm NSMOOTH = nint(5.*(13500./dxm)) do j = jsta_2l, jend_2u do i = 1, im @@ -3607,7 +3608,7 @@ SUBROUTINE MDLFLD ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex LPBL(I,J)=LM if(ZINT(I,J,NINT(LMH(I,J))+1) 0) THEN !$omp parallel do private(i,j,jj) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ! if(GUST(I,J) > 200. .and. gust(i,j)0) THEN - allocate(PBLREGIME(im,jsta_2l:jend_2u)) + allocate(PBLREGIME(isx:iex,jsta_2l:jend_2u)) CALL CALPBLREGIME(PBLREGIME) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = PBLREGIME(I,J) ENDDO ENDDO @@ -3680,7 +3681,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3692,7 +3693,7 @@ SUBROUTINE MDLFLD ! IF(IGET(400)>0)THEN DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex !Initialed as 'undetected'. Nov. 17, 2014, B. ZHOU: !changed from SPVAL to -5000. to distinguish missing grids and undetected ! GRID1(I,J) = SPVAL @@ -3723,7 +3724,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3735,7 +3736,7 @@ SUBROUTINE MDLFLD IF(IGET(464)>0 .or. IGET(467)>0 .or. IGET(470)>0)THEN i=IM/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) +! if(me == 0) print*,'sending input to GTG i,j,hgt,gust',i,j,ZINT(i,j,LP1),gust(i,j) ! Use the existing 3D local arrays as cycled variables EL=SPVAL @@ -3748,10 +3749,10 @@ SUBROUTINE MDLFLD i=IM/2 j=jend ! 321,541 - print*,'GTG output: l,cat,mwt,gtg at',i,j - do l=1,lm - print*,l,catedr(i,j,l),mwt(i,j,l),gtg(i,j,l) - end do +! print*,'GTG output: l,cat,mwt,gtg at',i,j +! do l=1,lm +! print*,l,catedr(i,j,l),mwt(i,j,l),gtg(i,j,l) +! end do ENDIF IF (IGET(470)>0) THEN @@ -3759,7 +3760,7 @@ SUBROUTINE MDLFLD IF (LVLS(L,IGET(470))>0) THEN LL=LM-L+1 DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=gtg(i,j,LL) ENDDO ENDDO @@ -3770,7 +3771,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3778,7 +3779,7 @@ SUBROUTINE MDLFLD DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=catedr(i,j,LL) ENDDO ENDDO @@ -3789,14 +3790,14 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo endif DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=mwt(i,j,LL) ENDDO ENDDO @@ -3807,7 +3808,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3831,12 +3832,12 @@ SUBROUTINE MDLFLD icing_gfip = spval icing_gfis = spval DO J=JSTA,JEND - DO I=1,IM - if(i==50 .and. j==jsta .and. me == 0) then + DO I=isx,iex + 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) do l=1,lm - print*,'l,P,T,RH,CWM,QQW,QQI,QQR,QQS,QQG,OMEG',& + if(debugprint)print*,'l,P,T,RH,CWM,QQW,QQI,QQR,QQS,QQG,OMEG',& l,pmid(i,j,l),t(i,j,l),rh3d(i,j,l),cwm(i,j,l), & q(i,j,l),qqw(i,j,l),qqi(i,j,l), & qqr(i,j,l),qqs(i,j,l),qqg(i,j,l),& @@ -3865,12 +3866,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=isx,iex ! 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,GRIDisx,iex,JM) ! end if ! end do ENDIF diff --git a/sorc/ncep_post.fd/MISCLN.f b/sorc/ncep_post.fd/MISCLN.f index 9d80f393f..21e159f6c 100644 --- a/sorc/ncep_post.fd/MISCLN.f +++ b/sorc/ncep_post.fd/MISCLN.f @@ -89,7 +89,7 @@ SUBROUTINE MISCLN rhmin, rgamog, tfrz, small use ctlblk_mod, only: grib, cfld, fld_info, datapd, im, jsta, jend, jm, & nbnd, nbin_du, lm, htfd, spval, pthresh, nfd, petabnd, me,& - jsta_2l, jend_2u, MODELNAME + jsta_2l, jend_2u, MODELNAME,isx,iex use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml use grib2_module, only: pset use upp_physics, only: FPVSNEW, CALRH_PW, CALCAPE, CALCAPE2 @@ -109,13 +109,13 @@ SUBROUTINE MISCLN ! DECLARE VARIABLES. ! LOGICAL NORTH, FIELD1,FIELD2 - LOGICAL, dimension(IM,JSTA:JEND) :: DONE, DONE1 + LOGICAL, dimension(isx:iex,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(isx:iex,jsta:jend) :: P1D, T1D, Q1D, U1D, V1D, SHR1D, Z1D, & RH1D, EGRID1, EGRID2, EGRID3, EGRID4, & EGRID5, EGRID6, EGRID7, EGRID8 real, dimension(:,:,:),allocatable :: OMGBND, PWTBND, QCNVBND, & @@ -155,10 +155,10 @@ SUBROUTINE MISCLN !**************************************************************************** ! START MISCLN HERE. ! - 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)) + allocate(USHR1(isx:iex,jsta_2l:jend_2u),VSHR1(isx:iex,jsta_2l:jend_2u), & + USHR6(isx:iex,jsta_2l:jend_2u),VSHR6(isx:iex,jsta_2l:jend_2u)) + allocate(UST(isx:iex,jsta_2l:jend_2u),VST(isx:iex,jsta_2l:jend_2u), & + HELI(isx:iex,jsta_2l:jend_2u,2)) ! ! HELICITY AND STORM MOTION. iget1 = IGET(162) @@ -175,7 +175,7 @@ SUBROUTINE MISCLN IF (iget2 > 0) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = HELI(I,J,1) ENDDO ENDDO @@ -186,7 +186,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -196,7 +196,7 @@ SUBROUTINE MISCLN IF (iget3 > 0) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = HELI(I,J,2) ENDDO ENDDO @@ -207,7 +207,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -217,7 +217,7 @@ SUBROUTINE MISCLN IF (IGET(163) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = UST(I,J) ENDDO ENDDO @@ -227,7 +227,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -236,7 +236,7 @@ SUBROUTINE MISCLN IF (IGET(164) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = VST(I,J) ENDDO ENDDO @@ -246,7 +246,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -264,7 +264,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -283,7 +283,7 @@ SUBROUTINE MISCLN IF(IGET(430) > 0) THEN !$omp parallel do private(i,j,jj) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = USHR1(I,J) ENDDO ENDDO @@ -293,7 +293,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -302,7 +302,7 @@ SUBROUTINE MISCLN IF(IGET(431) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = VSHR1(I,J) ENDDO ENDDO @@ -312,7 +312,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -321,7 +321,7 @@ SUBROUTINE MISCLN IF(IGET(432) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = USHR6(I,J) ENDDO ENDDO @@ -331,7 +331,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -340,7 +340,7 @@ SUBROUTINE MISCLN IF(IGET(433) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = VSHR6(I,J) ENDDO ENDDO @@ -350,7 +350,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -377,7 +377,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=isx,iex if(PMID(I,J,1) 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = P1D(I,J) ENDDO ENDDO @@ -414,7 +414,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -431,7 +431,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -442,7 +442,7 @@ SUBROUTINE MISCLN IF (IGET(177) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = Z1D(I,J) ENDDO ENDDO @@ -452,7 +452,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -463,7 +463,7 @@ SUBROUTINE MISCLN IF (IGET(055) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = T1D(I,J) ENDDO ENDDO @@ -473,7 +473,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -489,7 +489,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -500,7 +500,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=isx,iex GRID1(I,J)=U1D(I,J) GRID2(I,J)=V1D(I,J) ENDDO @@ -512,7 +512,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -523,7 +523,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -535,7 +535,7 @@ SUBROUTINE MISCLN IF (IGET(058) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = SHR1D(I,J) ENDDO ENDDO @@ -545,7 +545,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -564,7 +564,7 @@ SUBROUTINE MISCLN MAXWU(IM,jsta:jend), MAXWV(IM,jsta:jend),MAXWT(IM,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex MAXWP(I,J)=SPVAL MAXWZ(I,J)=SPVAL MAXWU(I,J)=SPVAL @@ -576,7 +576,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=isx,iex DO L=1,LM IF (ABS(PMID(I,J,L)-SPVAL)<=SMALL .OR. & ABS(UH(I,J,L)-SPVAL)<=SMALL .OR. & @@ -599,7 +599,7 @@ SUBROUTINE MISCLN IF (IGET(173) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = MAXWP(I,J) ENDDO ENDDO @@ -609,7 +609,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -625,7 +625,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -635,7 +635,7 @@ SUBROUTINE MISCLN IF (IGET(174) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = MAXWZ(I,J) ENDDO ENDDO @@ -645,7 +645,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -656,7 +656,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=isx,iex GRID1(I,J) = MAXWU(I,J) GRID2(I,J) = MAXWV(I,J) ENDDO @@ -667,7 +667,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -676,7 +676,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -686,7 +686,7 @@ SUBROUTINE MISCLN IF (IGET(314) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=MAXWT(I,J) ENDDO ENDDO @@ -696,7 +696,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -803,7 +803,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = T7D(I,J,IFD) ENDDO ENDDO @@ -815,7 +815,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -829,7 +829,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -842,7 +842,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=isx,iex if ( T7D(I,J,IFD) > 600 ) then GRID1(I,J)=SPVAL else @@ -880,7 +880,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=isx,iex GRID1(I,J) = Q7D(I,J,IFD) ENDDO ENDDO @@ -892,7 +892,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -906,7 +906,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -932,7 +932,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=isx,iex GRID1(I,J) = P7D(I,J,IFD) ENDDO ENDDO @@ -944,7 +944,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -958,7 +958,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -984,7 +984,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=isx,iex GRID1(I,J) = ICINGFD(I,J,IFD) ENDDO ENDDO @@ -996,7 +996,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1010,7 +1010,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1025,7 +1025,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=isx,iex GRID1(I,J)=AERFD(I,J,IFD,1) ENDDO ENDDO @@ -1037,7 +1037,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1050,7 +1050,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=isx,iex GRID1(I,J)=AERFD(I,J,IFD,2) ENDDO ENDDO @@ -1062,7 +1062,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1075,7 +1075,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=isx,iex GRID1(I,J)=AERFD(I,J,IFD,3) ENDDO ENDDO @@ -1087,7 +1087,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1100,7 +1100,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=isx,iex GRID1(I,J)=AERFD(I,J,IFD,4) ENDDO ENDDO @@ -1112,7 +1112,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1125,7 +1125,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=isx,iex GRID1(I,J)=AERFD(I,J,IFD,5) ENDDO ENDDO @@ -1137,7 +1137,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1152,7 +1152,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=isx,iex GRID1(I,J)=U7D(I,J,IFD) GRID2(I,J)=V6D(I,J,IFD) ENDDO @@ -1166,7 +1166,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1182,7 +1182,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1195,7 +1195,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=isx,iex GRID1(I,J) = U7D(I,J,IFD) GRID2(I,J) = V6D(I,J,IFD) ENDDO @@ -1209,7 +1209,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1225,7 +1225,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1261,7 +1261,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(467))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=GTGFD(I,J,IFD) ENDDO ENDDO @@ -1272,7 +1272,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1298,7 +1298,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(468))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=CATFD(I,J,IFD) ENDDO ENDDO @@ -1309,7 +1309,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1335,7 +1335,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(469))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=MWTFD(I,J,IFD) ENDDO ENDDO @@ -1346,7 +1346,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1374,7 +1374,7 @@ SUBROUTINE MISCLN IF (IGET(062)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1385,7 +1385,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1396,7 +1396,7 @@ SUBROUTINE MISCLN IF (IGET(063)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RH1D(I,J) ENDDO ENDDO @@ -1408,7 +1408,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1419,7 +1419,7 @@ SUBROUTINE MISCLN IF (IGET(753)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = P1D(I,J) ENDDO ENDDO @@ -1429,7 +1429,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1445,7 +1445,7 @@ SUBROUTINE MISCLN IF (IGET(165)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1456,7 +1456,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1467,7 +1467,7 @@ SUBROUTINE MISCLN IF (IGET(350)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=RH1D(I,J)*100. ENDDO ENDDO @@ -1478,7 +1478,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1489,7 +1489,7 @@ SUBROUTINE MISCLN IF (IGET(756)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = P1D(I,J) ENDDO ENDDO @@ -1499,7 +1499,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1517,7 +1517,7 @@ SUBROUTINE MISCLN IF (IGET(776)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1528,7 +1528,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1539,7 +1539,7 @@ SUBROUTINE MISCLN IF (IGET(777)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=RH1D(I,J)*100. ENDDO ENDDO @@ -1550,7 +1550,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1561,7 +1561,7 @@ SUBROUTINE MISCLN IF (IGET(778)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=P1D(I,J) ENDDO ENDDO @@ -1571,7 +1571,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1589,7 +1589,7 @@ SUBROUTINE MISCLN IF (IGET(779)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1600,7 +1600,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1611,7 +1611,7 @@ SUBROUTINE MISCLN IF (IGET(780)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=RH1D(I,J)*100. ENDDO ENDDO @@ -1622,7 +1622,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1633,7 +1633,7 @@ SUBROUTINE MISCLN IF (IGET(781)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=P1D(I,J) ENDDO ENDDO @@ -1643,7 +1643,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1685,7 +1685,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EGRID2(i,j) = SPVAL ENDDO ENDDO @@ -1699,7 +1699,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=isx,iex GRID1(I,J) = PBND(I,J,LBND) ENDDO ENDDO @@ -1710,7 +1710,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1723,7 +1723,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=isx,iex GRID1(I,J)=TBND(I,J,LBND) ENDDO ENDDO @@ -1734,7 +1734,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1753,7 +1753,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1766,7 +1766,7 @@ 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=isx,iex GRID1(I,J)=RHBND(I,J,LBND) ENDDO ENDDO @@ -1779,7 +1779,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1799,7 +1799,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1812,7 +1812,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=isx,iex GRID1(I,J)=QBND(I,J,LBND) ENDDO ENDDO @@ -1824,7 +1824,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1837,7 +1837,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=isx,iex GRID1(I,J) = QCNVBND(I,J,LBND) ENDDO ENDDO @@ -1848,7 +1848,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1871,7 +1871,7 @@ SUBROUTINE MISCLN IF(FIELD1.OR.FIELD2)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = UBND(I,J,LBND) GRID2(I,J) = VBND(I,J,LBND) ENDDO @@ -1886,7 +1886,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1902,7 +1902,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1916,7 +1916,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=isx,iex GRID1(I,J) = OMGBND(I,J,LBND) ENDDO ENDDO @@ -1927,7 +1927,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1940,7 +1940,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=isx,iex GRID1(I,J) = PWTBND(I,J,LBND) ENDDO ENDDO @@ -1952,7 +1952,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1973,7 +1973,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1983,7 +1983,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=isx,iex EGRID2(I,J) = MIN(EGRID2(I,J),GRID1(I,J)) END DO END DO @@ -1998,7 +1998,7 @@ SUBROUTINE MISCLN ! IF (IGET(031)>0 .OR. IGET(573)>0 ) THEN ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=isx,iex ! EGRID1(I,J) = H99999 ! EGRID2(I,J) = H99999 ! ENDDO @@ -2008,14 +2008,14 @@ SUBROUTINE MISCLN ! CALL OTLFT(PBND(1,1,LBND),TBND(1,1,LBND), & ! QBND(1,1,LBND),EGRID2) ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=isx,iex ! EGRID1(I,J)=AMIN1(EGRID1(I,J),EGRID2(I,J)) ! ENDDO ! ENDDO ! 50 CONTINUE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=EGRID2(I,J) ENDDO ENDDO @@ -2036,7 +2036,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2074,7 +2074,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 ENDDO @@ -2085,7 +2085,7 @@ SUBROUTINE MISCLN QBND(1,jsta,LBND),EGRID1) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF (EGRID1(I,J) > EGRID2(I,J)) THEN EGRID2(I,J) = EGRID1(I,J) LB2(I,J) = LVLBND(I,J,LBND) @@ -2106,7 +2106,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -2118,7 +2118,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2130,7 +2130,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -2139,7 +2139,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -2151,7 +2151,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2164,7 +2164,7 @@ SUBROUTINE MISCLN IF(IGET(221) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = PBLH(I,J) ENDDO ENDDO @@ -2174,7 +2174,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2189,7 +2189,7 @@ SUBROUTINE MISCLN IF (IGET(109)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID2(I,J) ENDDO ENDDO @@ -2199,7 +2199,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2208,7 +2208,7 @@ SUBROUTINE MISCLN IF (IGET(110)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -2218,7 +2218,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2242,7 +2242,7 @@ SUBROUTINE MISCLN 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=isx,iex 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 @@ -2252,7 +2252,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=isx,iex 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= ', & @@ -2276,7 +2276,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=isx,iex 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)) @@ -2345,7 +2345,7 @@ SUBROUTINE MISCLN IF (IGET(097) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = T89671(I,J) ! IF(T89671(I,J)>350.)PRINT*,'LARGE T89671 ', & ! I,J,T89671(I,J) @@ -2358,7 +2358,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2369,7 +2369,7 @@ SUBROUTINE MISCLN IF (IGET(098)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = T78483(I,J) ENDDO ENDDO @@ -2380,7 +2380,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2403,7 +2403,7 @@ SUBROUTINE MISCLN IF (IGET(091)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = PBND(I,J,1) ENDDO ENDDO @@ -2413,7 +2413,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2424,7 +2424,7 @@ SUBROUTINE MISCLN IF (IGET(092)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = TBND(I,J,1) ENDDO ENDDO @@ -2435,7 +2435,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2446,7 +2446,7 @@ SUBROUTINE MISCLN IF (IGET(093)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = QBND(I,J,1) ENDDO ENDDO @@ -2458,7 +2458,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2469,7 +2469,7 @@ SUBROUTINE MISCLN IF (IGET(094)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RHBND(I,J,1) ENDDO ENDDO @@ -2482,7 +2482,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2493,7 +2493,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=isx,iex GRID1(I,J) = UBND(I,J,1) GRID2(I,J) = VBND(I,J,1) ENDDO @@ -2506,7 +2506,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2520,7 +2520,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2555,7 +2555,7 @@ SUBROUTINE MISCLN IF (IGET(066)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RH3310(I,J) ENDDO ENDDO @@ -2568,7 +2568,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2581,7 +2581,7 @@ SUBROUTINE MISCLN IF (IGET(081)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RH6610(I,J) ENDDO ENDDO @@ -2594,7 +2594,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2605,7 +2605,7 @@ SUBROUTINE MISCLN IF (IGET(082)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RH3366(I,J) ENDDO ENDDO @@ -2618,7 +2618,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2629,7 +2629,7 @@ SUBROUTINE MISCLN IF (IGET(104)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = PW3310(I,J) ENDDO ENDDO @@ -2641,7 +2641,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2665,7 +2665,7 @@ SUBROUTINE MISCLN IF (IGET(099)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RH4710(I,J) ENDDO ENDDO @@ -2678,7 +2678,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2689,7 +2689,7 @@ SUBROUTINE MISCLN IF (IGET(100)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RH4796(I,J) ENDDO ENDDO @@ -2702,7 +2702,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2713,7 +2713,7 @@ SUBROUTINE MISCLN IF (IGET(101)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RH1847(I,J) ENDDO ENDDO @@ -2726,7 +2726,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2737,7 +2737,7 @@ SUBROUTINE MISCLN IF (IGET(102)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RH8498(I,J) ENDDO ENDDO @@ -2750,7 +2750,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2762,7 +2762,7 @@ SUBROUTINE MISCLN ! CONVERT TO DIVERGENCE FOR GRIB !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = -1.0*QM8510(I,J) ENDDO ENDDO @@ -2773,7 +2773,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2794,7 +2794,7 @@ SUBROUTINE MISCLN IF (IGET(318)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RH4410(I,J)*100. ENDDO ENDDO @@ -2806,7 +2806,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2817,7 +2817,7 @@ SUBROUTINE MISCLN IF (IGET(319)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = RH7294(I,J)*100. ENDDO ENDDO @@ -2829,7 +2829,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2840,7 +2840,7 @@ SUBROUTINE MISCLN IF (IGET(320)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J)=RH4472(I,J)*100. ENDDO ENDDO @@ -2852,7 +2852,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2867,7 +2867,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=isx,iex 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)) @@ -2887,7 +2887,7 @@ SUBROUTINE MISCLN IF (IGET(321)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = T(I,J,LM)+(T(I,J,LM-1)-T(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -2899,7 +2899,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2911,7 +2911,7 @@ SUBROUTINE MISCLN IF (IGET(322)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID2(I,J) = T(I,J,LM)+(T(I,J,LM-1)-T(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -2924,7 +2924,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2934,7 +2934,7 @@ SUBROUTINE MISCLN IF (IGET(323)>0) THEN !$omp parallel do private(i,j,es1,qs1,rh1,es2,qs2,rh2) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex ES1 = min(PMID(I,J,LM),FPVSNEW(T(I,J,LM))) QS1 = CON_EPS*ES1/(PMID(I,J,LM)+CON_EPSM1*ES1) RH1 = Q(I,J,LM)/QS1 @@ -2952,7 +2952,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2962,7 +2962,7 @@ SUBROUTINE MISCLN IF (IGET(324)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = UH(I,J,LM)+(UH(I,J,LM-1)-UH(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -2974,7 +2974,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2984,7 +2984,7 @@ SUBROUTINE MISCLN IF (IGET(325)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = VH(I,J,LM)+(VH(I,J,LM-1)-VH(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -2996,7 +2996,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3006,7 +3006,7 @@ SUBROUTINE MISCLN IF (IGET(326)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = OMGA(I,J,LM)+(OMGA(I,J,LM-1)-OMGA(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -3018,7 +3018,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3050,13 +3050,13 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 ! ENDDO ! ENDDO ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=isx,iex LB2(I,J) = (LVLBND(I,J,1) + LVLBND(I,J,2) + & LVLBND(I,J,3))/3 P1D(I,J) = (PBND(I,J,1) + PBND(I,J,2) + PBND(I,J,3))/3 @@ -3074,7 +3074,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -3087,7 +3087,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3098,7 +3098,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -3107,7 +3107,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -3119,7 +3119,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3135,7 +3135,7 @@ SUBROUTINE MISCLN ! CALL CALLCL(P1D,T1D,Q1D,EGRID1,EGRID2) ! IF (IGET(109)>0) THEN ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=isx,iex ! GRID1(I,J)=EGRID2(I,J) ! ENDDO ! ENDDO @@ -3143,12 +3143,12 @@ SUBROUTINE MISCLN ! ID(1:25) = 0 ! ! CALL GRIBIT(IGET(109),1, -! X GRID1,IM,JM) +! X GRIDisx,iex,JM) ! ENDIF ! ! IF (IGET(110)>0) THEN ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=isx,iex ! GRID1(I,J)=EGRID1(I,J) ! ENDDO ! ENDDO @@ -3156,7 +3156,7 @@ SUBROUTINE MISCLN ! ID(1:25) = 0 ! ! CALL GRIBIT(IGET(110),1, -! X GRID1,IM,JM) +! X GRIDisx,iex,JM) ! ENDIF ! ENDIF ! @@ -3185,7 +3185,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 ENDDO @@ -3200,7 +3200,7 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -3212,7 +3212,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3225,14 +3225,14 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex 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=isx,iex IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -3243,7 +3243,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3255,7 +3255,7 @@ SUBROUTINE MISCLN IF (IGET(443)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID4(I,J) ENDDO ENDDO @@ -3266,7 +3266,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3278,7 +3278,7 @@ SUBROUTINE MISCLN IF (IGET(246)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -3292,7 +3292,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3303,7 +3303,7 @@ SUBROUTINE MISCLN IF (IGET(444)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF (CPRATE(I,J) > PTHRESH) THEN GRID1(I,J) = EGRID5(I,J) ELSE @@ -3319,7 +3319,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3353,7 +3353,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 EGRID3(I,J) = -H99999 @@ -3365,7 +3365,7 @@ SUBROUTINE MISCLN ! ENDDO ! ENDDO ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=isx,iex LB2(I,J) = (LVLBND(I,J,1) + LVLBND(I,J,2) + & LVLBND(I,J,3))/3 P1D(I,J) = (PBND(I,J,1) + PBND(I,J,2) + PBND(I,J,3))/3 @@ -3387,7 +3387,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -3399,7 +3399,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3411,7 +3411,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -3420,7 +3420,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -3432,7 +3432,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3444,7 +3444,7 @@ SUBROUTINE MISCLN IF (IGET(952)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -3456,7 +3456,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3485,7 +3485,7 @@ SUBROUTINE MISCLN DEPTH(2) = 1000.0 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex LLOW(I,J) = INT(EGRID4(I,J)) LUPP(I,J) = INT(EGRID5(I,J)) ENDDO @@ -3497,7 +3497,7 @@ SUBROUTINE MISCLN IF (iget2 > 0) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = HELI(I,J,1) ! GRID1(I,J) = HELI(I,J,2) ENDDO @@ -3509,7 +3509,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3523,7 +3523,7 @@ SUBROUTINE MISCLN IF (IGET(957)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = CANGLE(I,J) ! IF(EGRID1(I,J)<100. .OR. EGRID2(I,J)>-250.) THEN ! GRID1(I,J) = 0. @@ -3537,7 +3537,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3549,7 +3549,7 @@ SUBROUTINE MISCLN IF (IGET(955)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID7(I,J) ENDDO ENDDO @@ -3561,7 +3561,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3573,7 +3573,7 @@ SUBROUTINE MISCLN IF (IGET(956)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex GRID1(I,J) = EGRID8(I,J) ENDDO ENDDO @@ -3585,7 +3585,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3596,7 +3596,7 @@ SUBROUTINE MISCLN ITYPE = 1 ! DO J=JSTA,JEND - ! DO I=1,IM + ! DO I=isx,iex ! LB2(I,J) = (LVLBND(I,J,1) + LVLBND(I,J,2) + & ! LVLBND(I,J,3))/3 ! P1D(I,J) = (PBND(I,J,1) + PBND(I,J,2) + PBND(I,J,3))/3 @@ -3614,7 +3614,7 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=isx,iex IF(T1D(I,J) < spval) GRID1(I,J) = -EGRID6(I,J) ENDDO ENDDO @@ -3626,7 +3626,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3667,7 +3667,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=isx,iex datapd(i,j,cfld) = GRID1(i,jj) enddo enddo diff --git a/sorc/ncep_post.fd/PROCESS.f b/sorc/ncep_post.fd/PROCESS.f index a82c346a4..dfbf39471 100644 --- a/sorc/ncep_post.fd/PROCESS.f +++ b/sorc/ncep_post.fd/PROCESS.f @@ -80,7 +80,7 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! ! COMPUTE/POST FIELDS ON MDL SURFACES. ! -!!! if(ifirstt .eq. 0 .and. me .eq. 0) call tracebackqq(' GWVX FROM PROCESS',-1) +! if(ifirstt .eq. 0 .and. me .eq. 0) call tracebackqq(' GWVX FROM PROCESS',-1) btim = timef() CALL MDLFLD ETAFLD2_tim = ETAFLD2_tim +(timef() - btim) From 9679366acf4501ba777bb62bf23515b8c549a4bb Mon Sep 17 00:00:00 2001 From: George Vandenberghe Date: Fri, 30 Apr 2021 16:09:40 +0000 Subject: [PATCH 05/77] Changed isx and iex to ISTA and IEND in listed routines. ISTA had prior use in MDL2P.f and that needed changing. IEND had prior use in PARA_CONFIG, changed to IENDJ in PARA_CONFIG2 where needed PARA_CONFIG did not need changing --- sorc/ncep_post.fd/CLDRAD.f | 426 ++++++++++++------------- sorc/ncep_post.fd/CTLBLK.f | 4 +- sorc/ncep_post.fd/MDL2AGL.f | 92 +++--- sorc/ncep_post.fd/MDL2P.f | 369 ++++++++++----------- sorc/ncep_post.fd/MDL2SIGMA.f | 98 +++--- sorc/ncep_post.fd/MDL2SIGMA2.f | 12 +- sorc/ncep_post.fd/MDLFLD.f | 458 +++++++++++++------------- sorc/ncep_post.fd/MISCLN.f | 496 ++++++++++++++--------------- sorc/ncep_post.fd/MPI_FIRST.f | 10 +- sorc/ncep_post.fd/PARA_RANGE.f | 12 +- sorc/ncep_post.fd/SURFCE.f | 564 ++++++++++++++++----------------- 11 files changed, 1272 insertions(+), 1269 deletions(-) diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index f8176b90d..a8b54386d 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -123,7 +123,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,isx,iex + JM, LM, gocart_on, me,ista,iend use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD use gridspec_mod, only: dyval, gridtype use cmassi_mod, only: TRAD_ice @@ -140,10 +140,10 @@ SUBROUTINE CLDRAD ! ! LOGICAL,dimension(im,jm) :: NEED INTEGER :: lcbot,lctop,jc,ic !bsf - INTEGER,dimension(isx:iex,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(isx:iex,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, & @@ -158,7 +158,7 @@ SUBROUTINE CLDRAD ceil_min, ceil_neighbor real,dimension(im,jm) :: ceil ! B ZHOU: For aviation: - REAL, dimension(isx:iex,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, & @@ -168,8 +168,8 @@ SUBROUTINE CLDRAD ! real FULL_CLD(IM,JM) !-- Must be dimensioned for the full domain ! - real dummy(isx:iex,jsta:jend) - integer idummy(isx:iex,jsta:jend) + real dummy(ista:iend,jsta:jend) + integer idummy(ista:iend,jsta:jend) ! ! --- Revision added for GOCART --- @@ -214,7 +214,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(isx:iex,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(:,:,:) @@ -222,10 +222,10 @@ SUBROUTINE CLDRAD INTEGER :: IH1, IH2 INTEGER :: IOS, INDX, ISSAM, ISSCM, ISUSO, IWASO, ISOOT, NBIN REAL :: CCDRY, CCWET, SSAM, SSCM - REAL,dimension(isx:iex,jsta:jend) :: AOD_DU, AOD_SS, AOD_SU, AOD_OC, AOD_BC, AOD - REAL,dimension(isx:iex,jsta:jend) :: SCA_DU, SCA_SS, SCA_SU, SCA_OC,SCA_BC, SCA2D - REAL,dimension(isx:iex,jsta:jend) :: ASY_DU, ASY_SS, ASY_SU, ASY_OC, ASY_BC,ASY2D - REAL,dimension(isx:iex,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 @@ -264,7 +264,7 @@ SUBROUTINE CLDRAD IF (IGET(030)>0.OR.IGET(572)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID1(I,J) = SPVAL ENDDO ENDDO @@ -274,14 +274,14 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'RAPR') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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=isx,iex + DO I=ista,iend IF(EGRID1(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) + TFRZ ENDDO ENDDO @@ -294,7 +294,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -309,7 +309,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend if (grid1(i,jj) /= spval) grid1(i,jj) = grid1(i,jj) - tfrz datapd(i,j,cfld) = GRID1(i,jj) enddo @@ -335,7 +335,7 @@ SUBROUTINE CLDRAD EGRID3,dummy,dummy) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(FIS(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -346,7 +346,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -363,7 +363,7 @@ SUBROUTINE CLDRAD IF ( (LVLS(1,IGET(032)) > 0) )THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(FIS(I,J) < SPVAL) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -377,7 +377,7 @@ SUBROUTINE CLDRAD EGRID3,dummy,dummy) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(FIS(I,J) < SPVAL) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -385,7 +385,7 @@ SUBROUTINE CLDRAD CALL BOUND(GRID1,D00,H99999) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(FIS(I,J) < SPVAL) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -395,7 +395,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -411,7 +411,7 @@ SUBROUTINE CLDRAD GRID1 = spval CALL CALPW(GRID1(1,jsta),1) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(FIS(I,J) >= SPVAL) GRID1(I,J)=spval END DO END DO @@ -422,7 +422,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -441,7 +441,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -460,7 +460,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -471,7 +471,7 @@ SUBROUTINE CLDRAD IF (IGET(200) > 0 .or. IGET(575) > 0) THEN IF (MODELNAME == 'RAPR') THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = LWP(I,J)/1000.0 ! use WRF-diagnosed value ENDDO ENDDO @@ -482,7 +482,7 @@ SUBROUTINE CLDRAD CALL CALPW(GRID2(1,jsta),3) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = GRID1(I,J) + GRID2(I,J) ENDDO ENDDO @@ -497,7 +497,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -510,7 +510,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -523,7 +523,7 @@ SUBROUTINE CLDRAD IF (IGET(201) > 0) THEN IF (MODELNAME == 'RAPR') THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = IWP(I,J)/1000.0 ! use WRF-diagnosed value ENDDO ENDDO @@ -537,7 +537,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -554,7 +554,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -571,7 +571,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -589,7 +589,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -607,7 +607,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -624,7 +624,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -641,7 +641,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -657,7 +657,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -673,7 +673,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -690,7 +690,7 @@ SUBROUTINE CLDRAD ENDIF !$omp parallel do DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = GRID1(I,J)*RRNUM ENDDO ENDDO @@ -723,7 +723,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -740,7 +740,7 @@ SUBROUTINE CLDRAD ENDIF !$omp parallel do DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = GRID1(I,J)*RRNUM ENDDO ENDDO @@ -773,7 +773,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -809,7 +809,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -819,7 +819,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=isx,iex + 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 @@ -859,7 +859,7 @@ SUBROUTINE CLDRAD IF (IGET(288)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=GRID2(I,J) ENDDO ENDDO @@ -869,7 +869,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -882,7 +882,7 @@ 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=isx,iex + DO I=ista,iend GRID1(I,J) = CLDEFI(I,J) ENDDO ENDDO @@ -901,7 +901,7 @@ SUBROUTINE CLDRAD ! also a method for cloud ceiling height ! DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend CFRACL(I,J)=0. CFRACM(I,J)=0. CFRACH(I,J)=0. @@ -921,7 +921,7 @@ SUBROUTINE CLDRAD ! write (0,*) 'numr,dyval,DY_m=',numr,dyval,DY_m DO L=LM,1,-1 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend if(CFR(I,J,L)=PTOP_LOW) THEN @@ -1006,7 +1006,7 @@ SUBROUTINE CLDRAD IF (IGET(799)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -1026,7 +1026,7 @@ SUBROUTINE CLDRAD IF (IGET(037) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(CFRACL(I,J) < SPVAL) then GRID1(I,J) = CFRACL(I,J)*100. else @@ -1040,7 +1040,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1051,7 +1051,7 @@ SUBROUTINE CLDRAD IF (IGET(300) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(AVGCFRACL(I,J) < SPVAL) then GRID1(I,J) = AVGCFRACL(I,J)*100. else @@ -1090,7 +1090,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1102,7 +1102,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(CFRACM(I,J) < SPVAL) then GRID1(I,J) = CFRACM(I,J)*100. else @@ -1116,7 +1116,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1127,7 +1127,7 @@ SUBROUTINE CLDRAD IF (IGET(301) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(ABS(AVGCFRACM(I,J)-SPVAL)>SMALL)THEN GRID1(I,J) = AVGCFRACM(I,J)*100. ELSE @@ -1166,7 +1166,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1178,7 +1178,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(CFRACH(I,J) < SPVAL) then GRID1(I,J) = CFRACH(I,J)*100. else @@ -1192,7 +1192,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1204,7 +1204,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(AVGCFRACH(I,J) < SPVAL) then GRID1(I,J) = AVGCFRACH(I,J)*100. else @@ -1243,7 +1243,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1256,7 +1256,7 @@ SUBROUTINE CLDRAD IF(MODELNAME=='NCAR' .OR. MODELNAME=='RAPR')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(i,j) = SPVAL egrid1(i,j)=0. do l = 1,LM @@ -1268,7 +1268,7 @@ SUBROUTINE CLDRAD ELSE IF (MODELNAME=='NMM'.OR.MODELNAME=='FV3R' & .OR. MODELNAME=='GFS')THEN DO J=JSTA,JEND - DO I=isx,iex + 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))* & @@ -1280,7 +1280,7 @@ SUBROUTINE CLDRAD END IF !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -1294,7 +1294,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1308,7 +1308,7 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(ABS(AVGTCDC(I,J)-SPVAL) > SMALL) then GRID1(I,J) = AVGTCDC(I,J)*100. else @@ -1319,7 +1319,7 @@ SUBROUTINE CLDRAD ELSE IF(MODELNAME == 'NMM')THEN DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -1368,7 +1368,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1381,7 +1381,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF (NCFRST(I,J)>0.0) THEN GRID1(I,J) = ACFRST(I,J)/NCFRST(I,J)*100. ELSE @@ -1429,7 +1429,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF (NCFRCV(I,J)>0.0) THEN GRID1(I,J) = ACFRCV(I,J)/NCFRCV(I,J)*100. ELSE @@ -1485,7 +1485,7 @@ SUBROUTINE CLDRAD !--- Rain is not part of cloud, only cloud water + cloud ice + snow ! DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend ! !--- Various convective cloud base & cloud top levels ! @@ -1616,7 +1616,7 @@ SUBROUTINE CLDRAD IF (IGET(758)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = CLDZCu(I,J) ENDDO ENDDO @@ -1635,7 +1635,7 @@ SUBROUTINE CLDRAD ! IF ((IGET(148)>0) .OR. (IGET(178)>0) .OR.(IGET(260)>0) ) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IBOT=IBOTT(I,J) !-- Cloud base ("bottoms") IF(MODELNAME == 'RAPR') then IF (IBOT <= 0) THEN @@ -1666,7 +1666,7 @@ SUBROUTINE CLDRAD ! CLOUD BOTTOM PRESSURE IF (IGET(148)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -1680,7 +1680,7 @@ SUBROUTINE CLDRAD IF (IGET(178)>0) THEN !--- Parameter was set to 148 in operational code (Ferrier, Feb '02) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -1719,7 +1719,7 @@ SUBROUTINE CLDRAD DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend ! !- imported from RUC post IF(MODELNAME == 'RAPR') then @@ -1911,7 +1911,7 @@ SUBROUTINE CLDRAD nlifr = 0 DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -1922,7 +1922,7 @@ SUBROUTINE CLDRAD IF (IGET(408)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -1946,7 +1946,7 @@ SUBROUTINE CLDRAD ceiling_thresh_cldfra = 0.5 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend ceil(I,J) = SPVAL zceil = SPVAL cldfra_max = 0. @@ -2017,7 +2017,7 @@ SUBROUTINE CLDRAD ! proceed to gridding DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = ceil(I,J) ENDDO ENDDO @@ -2047,7 +2047,7 @@ SUBROUTINE CLDRAD const1 = 3.912 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend ceil(I,J) = SPVAL zceil = SPVAL zceil1 = SPVAL @@ -2165,7 +2165,7 @@ SUBROUTINE CLDRAD ! layer. numr = 1 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend ceil_min = max( ceil(I,J)-FIS(I,J)*GI , 5.0) ! ceil_min in AGL do jc = max(JSTA,J-numr),min(JEND,J+numr) do ic = max(1,I-numr),min(IM,I+numr) @@ -2191,7 +2191,7 @@ SUBROUTINE CLDRAD IF (IGET(711)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -2206,7 +2206,7 @@ SUBROUTINE CLDRAD IF (IGET(798)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -2224,7 +2224,7 @@ SUBROUTINE CLDRAD IF (IGET(260)>0) THEN CALL CALCEILING(CLDZ,TCLD,CEILING) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = CEILING(I,J) ENDDO ENDDO @@ -2238,7 +2238,7 @@ SUBROUTINE CLDRAD IF (IGET(261) > 0) THEN CALL CALFLTCND(CEILING,GRID1(1,jsta)) ! DO J=JSTA,JEND -! DO I=isx,iex +! DO I=ista,iend ! GRID1(I,J) = FLTCND(I,J) ! ENDDO ! ENDDO @@ -2248,7 +2248,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2261,13 +2261,13 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PBOT(I,J) ENDDO ENDDO ELSE DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -2283,7 +2283,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2294,7 +2294,7 @@ SUBROUTINE CLDRAD ! IF (IGET(192) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -2313,7 +2313,7 @@ SUBROUTINE CLDRAD ! IF (IGET(190) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -2332,7 +2332,7 @@ SUBROUTINE CLDRAD ! IF (IGET(194) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -2352,7 +2352,7 @@ SUBROUTINE CLDRAD ! IF (IGET(303) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend ! IF(PBOTL(I,J) > SMALL)THEN GRID1(I,J) = PBOTL(I,J) ! ELSE @@ -2395,7 +2395,7 @@ SUBROUTINE CLDRAD ! IF (IGET(306) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(PBOTM(I,J) > SMALL)THEN GRID1(I,J) = PBOTM(I,J) ELSE @@ -2438,7 +2438,7 @@ SUBROUTINE CLDRAD ! IF (IGET(309) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(PBOTH(I,J) > SMALL)THEN GRID1(I,J) = PBOTH(I,J) ELSE @@ -2487,7 +2487,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=isx,iex + 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=isx,iex + DO I=ista,iend GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -2537,7 +2537,7 @@ SUBROUTINE CLDRAD ! IF (IGET(179)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -2555,7 +2555,7 @@ SUBROUTINE CLDRAD Cloud_def_p = 0.0000001 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend ! imported from RUC post ! Cloud top zcldtop = -5000. @@ -2619,7 +2619,7 @@ SUBROUTINE CLDRAD ! IF (IGET(406)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -2633,7 +2633,7 @@ SUBROUTINE CLDRAD ! IF (IGET(409)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -2649,7 +2649,7 @@ SUBROUTINE CLDRAD ! IF (IGET(168)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = CLDT(I,J) ENDDO ENDDO @@ -2665,7 +2665,7 @@ SUBROUTINE CLDRAD num_thick=0 ! for debug GRID1=spval DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend opdepth=0. llmh=nint(lmh(i,j)) !bsf - start @@ -2765,13 +2765,13 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PTOP(I,J) ENDDO ENDDO ELSE DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -2787,7 +2787,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2798,7 +2798,7 @@ SUBROUTINE CLDRAD ! IF (IGET(193) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -2817,7 +2817,7 @@ SUBROUTINE CLDRAD ! IF (IGET(191) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -2837,7 +2837,7 @@ SUBROUTINE CLDRAD ! IF (IGET(195) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -2857,7 +2857,7 @@ SUBROUTINE CLDRAD ! IF (IGET(304) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(PTOPL(I,J) > SMALL)THEN GRID1(I,J) = PTOPL(I,J) ELSE @@ -2900,7 +2900,7 @@ SUBROUTINE CLDRAD ! IF (IGET(307) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PTOPM(I,J) ENDDO ENDDO @@ -2939,7 +2939,7 @@ SUBROUTINE CLDRAD ! IF (IGET(310) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PTOPH(I,J) ENDDO ENDDO @@ -2979,7 +2979,7 @@ SUBROUTINE CLDRAD ! IF (IGET(305) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = TTOPL(I,J) ENDDO ENDDO @@ -3018,7 +3018,7 @@ SUBROUTINE CLDRAD ! IF (IGET(308) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = TTOPM(I,J) ENDDO ENDDO @@ -3057,7 +3057,7 @@ SUBROUTINE CLDRAD ! IF (IGET(311) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = TTOPH(I,J) ENDDO ENDDO @@ -3097,7 +3097,7 @@ SUBROUTINE CLDRAD IF (IGET(196) > 0.or.IGET(570)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend if(CNVCFR(I,J)/=SPVAL)GRID1(I,J)=100.*CNVCFR(I,J) !-- convert to percent ENDDO ENDDO @@ -3121,7 +3121,7 @@ SUBROUTINE CLDRAD IF (IGET(342) > 0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend if(PBLCFR(I,J)/=SPVAL)GRID1(I,J)=100.*PBLCFR(I,J) !-- convert to percent ENDDO ENDDO @@ -3161,7 +3161,7 @@ SUBROUTINE CLDRAD ! IF (IGET(313) > 0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=cldwork(I,J) ENDDO ENDDO @@ -3213,7 +3213,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(ASWIN(I,J)/=SPVAL)THEN GRID1(I,J) = ASWIN(I,J)*RRNUM ELSE @@ -3266,7 +3266,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(AUVBIN(I,J)/=SPVAL)THEN GRID1(I,J) = AUVBIN(I,J)*RRNUM ELSE @@ -3320,7 +3320,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(AUVBINC(I,J)/=SPVAL)THEN GRID1(I,J) = AUVBINC(I,J)*RRNUM ELSE @@ -3373,7 +3373,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(ALWIN(I,J)/=SPVAL)THEN GRID1(I,J) = ALWIN(I,J)*RRNUM ELSE @@ -3425,7 +3425,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(ASWOUT(I,J)/=SPVAL)THEN GRID1(I,J) = -1.0*ASWOUT(I,J)*RRNUM ELSE @@ -3477,7 +3477,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(ALWOUT(I,J)/=SPVAL)THEN GRID1(I,J) = -1.0*ALWOUT(I,J)*RRNUM ELSE @@ -3529,7 +3529,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(ASWTOA(I,J)/=SPVAL)THEN GRID1(I,J) = ASWTOA(I,J)*RRNUM ELSE @@ -3581,7 +3581,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(ALWTOA(I,J)/=SPVAL)THEN GRID1(I,J) = ALWTOA(I,J)*RRNUM ELSE @@ -3627,7 +3627,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RLWTOA(I,J) ENDDO ENDDO @@ -3646,7 +3646,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(RLWTOA(I,J) < SPVAL) & & GRID1(I,J) = (RLWTOA(I,J)*STBOL)**0.25 ENDDO @@ -3662,7 +3662,7 @@ SUBROUTINE CLDRAD ! CURRENT INCOMING SW RADIATION AT THE SURFACE. IF (IGET(156)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(CZMEAN(I,J)>1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE @@ -3684,7 +3684,7 @@ SUBROUTINE CLDRAD ! dong add missing value to DLWRF GRID1 = spval DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -3711,7 +3711,7 @@ SUBROUTINE CLDRAD IF (IGET(141)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(CZMEAN(I,J)>1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE @@ -3731,7 +3731,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky upwelling SW at the surface IF (IGET(743)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SWUPBC(I,J) ENDDO ENDDO @@ -3746,7 +3746,7 @@ SUBROUTINE CLDRAD IF (IGET(142)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RADOT(I,J) ENDDO ENDDO @@ -3760,7 +3760,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky downwelling LW at the surface IF (IGET(744)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = LWDNBC(I,J) ENDDO ENDDO @@ -3774,7 +3774,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky upwelling LW at the surface IF (IGET(745)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = LWUPBC(I,J) ENDDO ENDDO @@ -3789,7 +3789,7 @@ SUBROUTINE CLDRAD IF (IGET(740)>0) THEN print *,"GETTING INTO MEAN_FRP PART" DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = MEAN_FRP(I,J) ENDDO ENDDO @@ -3805,7 +3805,7 @@ SUBROUTINE CLDRAD IF (IGET(262)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(CZMEAN(I,J)>1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE @@ -3824,7 +3824,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky downwelling SW at surface (GSD version) IF (IGET(742)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SWDNBC(I,J) ENDDO ENDDO @@ -3839,7 +3839,7 @@ SUBROUTINE CLDRAD IF (IGET(772)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SWDDNI(I,J) ENDDO ENDDO @@ -3853,7 +3853,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky SWDDNI IF (IGET(796)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SWDDNIC(I,J) ENDDO ENDDO @@ -3868,7 +3868,7 @@ SUBROUTINE CLDRAD IF (IGET(773)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SWDDIF(I,J) ENDDO ENDDO @@ -3882,7 +3882,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky SWDDIF IF (IGET(797)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SWDDIFC(I,J) ENDDO ENDDO @@ -3896,7 +3896,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED INCOMING CLEARSKY SW RADIATION AT THE SURFACE. IF (IGET(383)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = ASWINC(I,J) ENDDO ENDDO @@ -3934,7 +3934,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY SW RADIATION AT THE SURFACE. IF (IGET(386)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = ASWOUTC(I,J) ENDDO ENDDO @@ -3972,7 +3972,7 @@ SUBROUTINE CLDRAD ! Instantaneous all-sky outgoing SW flux at the model top IF (IGET(719)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SWUPT(I,J) ENDDO ENDDO @@ -3986,7 +3986,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY SW RADIATION AT THE MODEL TOP IF (IGET(387)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = ASWTOAC(I,J) ENDDO ENDDO @@ -4024,7 +4024,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED INCOMING SW RADIATION AT THE MODEL TOP IF (IGET(388)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = ASWINTOA(I,J) ENDDO ENDDO @@ -4062,7 +4062,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED INCOMING CLEARSKY LW RADIATION AT THE SURFACE IF (IGET(382)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = ALWINC(I,J) ENDDO ENDDO @@ -4100,7 +4100,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY LW RADIATION AT THE SURFACE IF (IGET(384)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = ALWOUTC(I,J) ENDDO ENDDO @@ -4138,7 +4138,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY LW RADIATION AT THE MODEL TOP IF (IGET(385)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = ALWTOAC(I,J) ENDDO ENDDO @@ -4176,7 +4176,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE BEAM DOWNWARD SOLAR FLUX IF (IGET(401)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = AVISBEAMSWIN(I,J) ENDDO ENDDO @@ -4216,7 +4216,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE DIFFUSE DOWNWARD SOLAR FLUX IF (IGET(402)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = AVISDIFFSWIN(I,J) ENDDO ENDDO @@ -4255,7 +4255,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE BEAM DOWNWARD SOLAR FLUX IF (IGET(403)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = AIRBEAMSWIN(I,J) ENDDO ENDDO @@ -4294,7 +4294,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE DIFFUSE DOWNWARD SOLAR FLUX IF (IGET(404)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = AIRDIFFSWIN(I,J) ENDDO ENDDO @@ -4333,7 +4333,7 @@ SUBROUTINE CLDRAD !2D AEROSOL OPTICAL DEPTH AT 550 NM IF (IGET(715)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend grid1(i,j)=taod5502d(i,j) ENDDO ENDDO @@ -4347,7 +4347,7 @@ SUBROUTINE CLDRAD !AEROSOL ASYMMETRY FACTOR IF (IGET(716)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend grid1(i,j)=aerasy2d(i,j) ENDDO ENDDO @@ -4361,7 +4361,7 @@ SUBROUTINE CLDRAD !AEROSOL SINGLE-SCATTERING ALBEDO IF (IGET(717)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend grid1(i,j)=aerssa2d(i,j) ENDDO ENDDO @@ -4551,13 +4551,13 @@ SUBROUTINE CLDRAD !!! COMPUTES RELATIVE HUMIDITY AND RDRH ! allocate (RH3D(im,jsta:jend,lm)) - allocate (rdrh(isx:iex,jsta:jend,lm)) - allocate (ihh(isx:iex,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=isx,iex + 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) @@ -4565,7 +4565,7 @@ SUBROUTINE CLDRAD ENDDO CALL CALRH(P1D,T1D,Q1D,EGRID4) DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -4653,7 +4653,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend DO L=1,LM DO N=1, NBIN_DU EXT01 = EXTRHD_DU(1,N,IB) @@ -4680,7 +4680,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend DO L=1,LM ih1 = ihh(I,J,L) ih2 = ih1 + 1 @@ -4714,7 +4714,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4747,7 +4747,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4779,7 +4779,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4809,7 +4809,7 @@ SUBROUTINE CLDRAD SCA=SPVAL ASY=SPVAL DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -4841,7 +4841,7 @@ SUBROUTINE CLDRAD IF (IB == 2 ) THEN !! AOD AT 440 NM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend AOD_440(I,J) = AOD(I,J) ENDDO ! I-loop ENDDO ! J-loop @@ -4850,7 +4850,7 @@ SUBROUTINE CLDRAD IF (IB == 5 ) THEN !! AOD AT 860 NM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend AOD_860(I,J) = AOD(I,J) ENDDO ! I-loop ENDDO ! J-loop @@ -4861,7 +4861,7 @@ SUBROUTINE CLDRAD IF ( IGET(INDX) > 0) THEN !$omp parallel do private(i,j) do j=jsta,jend - do i=isx,iex + do i=ista,iend GRID1(i,j) = AOD(i,j) enddo enddo @@ -4880,7 +4880,7 @@ SUBROUTINE CLDRAD IF ( IGET(649) > 0 ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF ( SCA2D(I,J) > 0.0 ) THEN ASY2D(I,J) = ASY2D(I,J) / SCA2D(I,J) ELSE @@ -4901,7 +4901,7 @@ SUBROUTINE CLDRAD IF ( IGET(648) > 0 ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF ( AOD(I,J) > 0.0 ) THEN SCA2D(I,J) = SCA2D(I,J) / AOD(I,J) ELSE @@ -4930,7 +4930,7 @@ SUBROUTINE CLDRAD IF ( IGET(650) > 0 ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=SCA2D(I,J) ENDDO ENDDO @@ -4949,7 +4949,7 @@ SUBROUTINE CLDRAD IF ( IGET(JJ) > 0) THEN ! EXT AOD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -4970,7 +4970,7 @@ SUBROUTINE CLDRAD IF ( IGET(JJ) > 0) THEN ! SCA AOD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -4999,7 +4999,7 @@ SUBROUTINE CLDRAD ANG2 = LOG ( 860. / 440. ) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -5024,7 +5024,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend GRID1(I,J) = DUEM(I,J,1)*1.E-6 DO K=2,NBIN_DU GRID1(I,J) = GRID1(I,J) + DUEM(I,J,K)*1.E-6 @@ -5042,7 +5042,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend GRID1(I,J) = DUSD(I,J,1)*1.E-6 DO K=2,NBIN_DU GRID1(I,J) = GRID1(I,J)+ DUSD(I,J,K)*1.E-6 @@ -5059,7 +5059,7 @@ SUBROUTINE CLDRAD ! ! IF (IGET(661)>0) THEN ! DO J = JSTA,JEND -! DO I = isx,iex +! 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 @@ -5069,7 +5069,7 @@ SUBROUTINE CLDRAD ! ID(1:25) = 0 ! ID(02)=141 ! if(grib=='grib1') then -! CALL GRIBIT(IGET(661),LVLS(1,IGET(661)),GRIDisx,iex,JM) +! CALL GRIBIT(IGET(661),LVLS(1,IGET(661)),GRIDista,iend,JM) ! elseif(grib=='grib2') then ! cfld=cfld+1 ! fld_info(cfld)%ifld=IAVBLFLD(IGET(661)) @@ -5081,7 +5081,7 @@ SUBROUTINE CLDRAD IF (IGET(686)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = DUSTPM(I,J) !ug/m3 END DO @@ -5096,7 +5096,7 @@ SUBROUTINE CLDRAD !! ADD DUST WET DEPOSITION FLUXES (kg/m2/sec) ! IF (IGET(662)>0) THEN ! DO J = JSTA,JEND -! DO I = isx,iex +! 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 @@ -5106,7 +5106,7 @@ SUBROUTINE CLDRAD ! ID(1:25) = 0 ! ID(02)=141 ! if(grib=='grib1') then -! CALL GRIBIT(IGET(662),LVLS(1,IGET(662)),GRIDisx,iex,JM) +! CALL GRIBIT(IGET(662),LVLS(1,IGET(662)),GRIDista,iend,JM) ! elseif(grib=='grib2') then ! cfld=cfld+1 ! fld_info(cfld)%ifld=IAVBLFLD(IGET(662)) @@ -5118,7 +5118,7 @@ SUBROUTINE CLDRAD IF (IGET(684)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = SSPM(I,J) !ug/m3 END DO @@ -5133,7 +5133,7 @@ SUBROUTINE CLDRAD IF (IGET(619)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = DUSMASS(I,J) !ug/m3 END DO @@ -5149,7 +5149,7 @@ SUBROUTINE CLDRAD IF (IGET(620)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend !GRID1(I,J) = DUSMASS25(I,J) * 1.E-6 GRID1(I,J) = DUSMASS25(I,J) ! ug/m3 END DO @@ -5164,7 +5164,7 @@ SUBROUTINE CLDRAD IF (IGET(621)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend !GRID1(I,J) = DUCMASS(I,J) * 1.E-6 GRID1(I,J) = DUCMASS(I,J) * 1.E-9 END DO @@ -5180,7 +5180,7 @@ SUBROUTINE CLDRAD IF (IGET(622)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend !GRID1(I,J) = DUCMASS25(I,J) * 1.E-6 GRID1(I,J) = DUCMASS25(I,J) * 1.E-9 END DO @@ -5196,7 +5196,7 @@ SUBROUTINE CLDRAD IF (IGET(646)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend GRID1(I,J) = DUSTCB(I,J) * 1.E-9 END DO END DO @@ -5211,7 +5211,7 @@ SUBROUTINE CLDRAD IF (IGET(647)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend GRID1(I,J) = SSCB(I,J) * 1.E-9 END DO END DO @@ -5225,7 +5225,7 @@ SUBROUTINE CLDRAD IF (IGET(616)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend GRID1(I,J) = BCCB(I,J) * 1.E-9 END DO END DO @@ -5240,7 +5240,7 @@ SUBROUTINE CLDRAD IF (IGET(617)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend GRID1(I,J) = OCCB(I,J) * 1.E-9 END DO END DO @@ -5255,7 +5255,7 @@ SUBROUTINE CLDRAD IF (IGET(618)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend GRID1(I,J) = SULFCB(I,J) * 1.E-9 END DO END DO @@ -5313,7 +5313,7 @@ SUBROUTINE CLDRAD ! CB cover is derived from CPRAT (same as #272 in SURFCE.f) EGRID1 = SPVAL DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend if(AVGCPRATE(I,J) /= SPVAL) then EGRID1(I,J) = AVGCPRATE(I,J)*(1000./DTQ2) end if @@ -5327,7 +5327,7 @@ SUBROUTINE CLDRAD EGRID3 = SPVAL IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') then DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID2(I,J) = PBOT(I,J) EGRID3(I,J) = PTOP(I,J) END DO @@ -5336,7 +5336,7 @@ SUBROUTINE CLDRAD ! Derive CB base and top, relationship among CB fields DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend if(EGRID1(I,J)<= 0. .or. EGRID2(I,J)<= 0. .or. EGRID3(I,J) <= 0.) then EGRID1(I,J) = SPVAL EGRID2(I,J) = SPVAL @@ -5345,7 +5345,7 @@ SUBROUTINE CLDRAD END DO END DO DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(EGRID2(I,J) == SPVAL .or. EGRID3(I,J) == SPVAL) cycle if(EGRID3(I,J) < 400.*100. .and. & (EGRID2(I,J)-EGRID3(I,J)) > 300.*100) then @@ -5394,7 +5394,7 @@ SUBROUTINE CLDRAD IF(IGET(473) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -5403,7 +5403,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5412,7 +5412,7 @@ SUBROUTINE CLDRAD IF(IGET(474) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID2(I,J) ENDDO ENDDO @@ -5421,7 +5421,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5430,7 +5430,7 @@ SUBROUTINE CLDRAD IF(IGET(475) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -5439,7 +5439,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5456,7 +5456,7 @@ 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,isx,iex + use ctlblk_mod, only: SPVAL,JSTA,JEND,IM,ista,iend implicit none real, intent(inout) :: cbcov(IM,JSTA:JEND) @@ -5509,7 +5509,7 @@ 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,isx,iex + cfld, datapd, fld_info, jsta_2l, jend_2u,ista,iend use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD implicit none ! @@ -5522,7 +5522,7 @@ subroutine wrt_aero_diag(igetfld,nbin,data) GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = isx,iex + DO I = ista,iend grid1(I,J) = data(I,J,1) DO K=2,NBIN GRID1(I,J) = GRID1(I,J)+ data(I,J,K) diff --git a/sorc/ncep_post.fd/CTLBLK.f b/sorc/ncep_post.fd/CTLBLK.f index 15ae026e4..c0de9633b 100644 --- a/sorc/ncep_post.fd/CTLBLK.f +++ b/sorc/ncep_post.fd/CTLBLK.f @@ -9,7 +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 03/29 George Vandenberghe. Add isx and iex upper and lower bounds for 2D decomposition +! 2021 03/29 George Vandenberghe. Add ista and iend upper and lower bounds for 2D decomposition ! !----------------------------------------------------------------------- ! @@ -62,7 +62,7 @@ module CTLBLK_mod MPI_COMM_COMP, IM,JM,LM,NSOIL,LP1,LM1,IM_JM, & lsm,lsmp1 !comm mpi ! - integer isx, iex ! <<---- GWV ADD upper and lower I dimensions for 2D decomposition + integer ista, iend ! <<---- GWV ADD upper and lower I dimensions for 2D decomposition real :: ARDSW, ARDLW, ASRFC, TSRFC,TRDLW,TRDSW,TCLOD,THEAT, & TPREC,TMAXMIN,TD3D !comm rad ! diff --git a/sorc/ncep_post.fd/MDL2AGL.f b/sorc/ncep_post.fd/MDL2AGL.f index 7ee65b9e5..38e4fe949 100644 --- a/sorc/ncep_post.fd/MDL2AGL.f +++ b/sorc/ncep_post.fd/MDL2AGL.f @@ -59,7 +59,7 @@ 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,isx,iex + jsta_2l, jend_2u, im, jm, jsta, jend, imp_physics,ista,iend use rqstfld_mod, only: iget, lvls, iavblfld, lvlsxml, id use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -76,9 +76,9 @@ SUBROUTINE MDL2AGL ! LOGICAL IOOMG,IOALL REAL,dimension(im,jsta_2l:jend_2u) :: grid1 - REAL,dimension(isx:iex,jsta_2l:jend_2u) :: UAGL, VAGL, tagl, pagl, qagl + REAL,dimension(ista:iend,jsta_2l:jend_2u) :: UAGL, VAGL, tagl, pagl, qagl ! - INTEGER,dimension(isx:iex,jsta_2l:jend_2u) :: NL1X + INTEGER,dimension(ista:iend,jsta_2l:jend_2u) :: NL1X integer,dimension(jm) :: IHE, IHW INTEGER LXXX,IERR, maxll, minll INTEGER ISTART,ISTOP,JSTART,JSTOP @@ -98,7 +98,7 @@ SUBROUTINE MDL2AGL ! ! REAL C1D(IM,JM),QW1(IM,JM),QI1(IM,JM),QR1(IM,JM) ! &, QS1(IM,JM) ,DBZ1(IM,JM) - REAL,dimension(isx:iex,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 @@ -150,7 +150,7 @@ SUBROUTINE MDL2AGL ii=float(im)/3.0 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend DBZ1(I,J) = SPVAL DBZR1(I,J) = SPVAL DBZI1(I,J) = SPVAL @@ -193,7 +193,7 @@ SUBROUTINE MDL2AGL ! DO 220 J=JSTA,JEND DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend LL = NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -276,13 +276,13 @@ SUBROUTINE MDL2AGL IF((IGET(253)>0) )THEN if(MODELNAME=='RAPR') then DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=DBZ1LOG(I,J) ENDDO ENDDO else DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=DBZ1(I,J) ENDDO ENDDO @@ -297,7 +297,7 @@ SUBROUTINE MDL2AGL !--- Radar reflectivity from rain IF((IGET(279)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=DBZR1(I,J) ENDDO ENDDO @@ -311,7 +311,7 @@ SUBROUTINE MDL2AGL !--- Radar reflectivity from all ice habits (snow + graupel + sleet, etc.) IF((IGET(280)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=DBZI1(I,J) ENDDO ENDDO @@ -325,7 +325,7 @@ SUBROUTINE MDL2AGL !--- Radar reflectivity from parameterized convection IF((IGET(281)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=DBZC1(I,J) ENDDO ENDDO @@ -350,7 +350,7 @@ SUBROUTINE MDL2AGL !--- Max Derived Radar Reflectivity IF((IGET(421)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=REFD_MAX(I,J) ENDDO ENDDO @@ -372,7 +372,7 @@ SUBROUTINE MDL2AGL !--- Max Derived Radar Reflectivity at -10C IF((IGET(785)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=REFDM10C_MAX(I,J) ENDDO ENDDO @@ -393,7 +393,7 @@ SUBROUTINE MDL2AGL !--- Max Updraft Helicity IF((IGET(420)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=UP_HELI_MAX(I,J) ENDDO ENDDO @@ -414,7 +414,7 @@ SUBROUTINE MDL2AGL !--- Max Updraft Helicity 1-6 km IF((IGET(700)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=UP_HELI_MAX16(I,J) ENDDO ENDDO @@ -435,7 +435,7 @@ SUBROUTINE MDL2AGL !--- Min Updraft Helicity IF((IGET(786)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=UP_HELI_MIN(I,J) ENDDO ENDDO @@ -456,7 +456,7 @@ SUBROUTINE MDL2AGL !--- Min Updraft Helicity 1-6 km IF((IGET(787)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=UP_HELI_MIN16(I,J) ENDDO ENDDO @@ -477,7 +477,7 @@ SUBROUTINE MDL2AGL !--- Max Updraft Helicity 0-2 km IF((IGET(788)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=UP_HELI_MAX02(I,J) ENDDO ENDDO @@ -497,7 +497,7 @@ SUBROUTINE MDL2AGL !--- Min Updraft Helicity 0-2 km IF((IGET(789)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=UP_HELI_MIN02(I,J) ENDDO ENDDO @@ -518,7 +518,7 @@ SUBROUTINE MDL2AGL !--- Max Updraft Helicity 0-3 km IF((IGET(790)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=UP_HELI_MAX03(I,J) ENDDO ENDDO @@ -539,7 +539,7 @@ SUBROUTINE MDL2AGL !--- Min Updraft Helicity 0-3 km IF((IGET(791)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=UP_HELI_MIN03(I,J) ENDDO ENDDO @@ -560,7 +560,7 @@ SUBROUTINE MDL2AGL !--- Max Relative Vertical Vorticity 0-2 km IF((IGET(792)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=REL_VORT_MAX(I,J) ENDDO ENDDO @@ -581,7 +581,7 @@ SUBROUTINE MDL2AGL !--- Max Relative Vertical Vorticity 0-1 km IF((IGET(793)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=REL_VORT_MAX01(I,J) ENDDO ENDDO @@ -601,7 +601,7 @@ SUBROUTINE MDL2AGL !--- Max Relative Vertical Vorticity @ hybrid level 1 IF((IGET(890)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=REL_VORT_MAXHY1(I,J) ENDDO ENDDO @@ -622,7 +622,7 @@ SUBROUTINE MDL2AGL !--- Max Hail Diameter in Column IF((IGET(794)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=HAIL_MAX2D(I,J) ENDDO ENDDO @@ -643,7 +643,7 @@ SUBROUTINE MDL2AGL !--- Max Hail Diameter at k=1 IF((IGET(795)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=HAIL_MAXK1(I,J) ENDDO ENDDO @@ -666,7 +666,7 @@ SUBROUTINE MDL2AGL ! (J. Kenyon/GSD, added 1 May 2019) IF((IGET(728)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=HAIL_MAXHAILCAST(I,J)/1000.0 ! convert mm to m ENDDO ENDDO @@ -687,7 +687,7 @@ SUBROUTINE MDL2AGL !--- Max Column Integrated Graupel IF((IGET(429)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=GRPL_MAX(I,J) ENDDO ENDDO @@ -708,7 +708,7 @@ SUBROUTINE MDL2AGL !--- Max Lightning Threat 1 IF((IGET(702)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=LTG1_MAX(I,J) ENDDO ENDDO @@ -729,7 +729,7 @@ SUBROUTINE MDL2AGL !--- Max Lightning Threat 2 IF((IGET(703)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=LTG2_MAX(I,J) ENDDO ENDDO @@ -750,7 +750,7 @@ SUBROUTINE MDL2AGL !--- Max Lightning Threat 3 IF((IGET(704)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=LTG3_MAX(I,J) ENDDO ENDDO @@ -771,7 +771,7 @@ SUBROUTINE MDL2AGL !--- GSD Updraft Helicity IF((IGET(727)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=UP_HELI(I,J) ENDDO ENDDO @@ -786,7 +786,7 @@ SUBROUTINE MDL2AGL !--- Updraft Helicity 1-6 km layer IF((IGET(701)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=UP_HELI16(I,J) ENDDO ENDDO @@ -801,7 +801,7 @@ SUBROUTINE MDL2AGL !--- Convective Initiation Lightning IF((IGET(705)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=NCI_LTG(I,J)/60.0 ENDDO ENDDO @@ -822,7 +822,7 @@ SUBROUTINE MDL2AGL !--- Convective Activity Lightning IF((IGET(706)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=NCA_LTG(I,J)/60.0 ENDDO ENDDO @@ -843,7 +843,7 @@ SUBROUTINE MDL2AGL !--- Convective Initiation Vertical Hydrometeor Flux IF((IGET(707)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=NCI_WQ(I,J)/60.0 ENDDO ENDDO @@ -864,7 +864,7 @@ SUBROUTINE MDL2AGL !--- Convective Activity Vertical Hydrometeor Flux IF((IGET(708)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=NCA_WQ(I,J)/60.0 ENDDO ENDDO @@ -885,7 +885,7 @@ SUBROUTINE MDL2AGL !--- Convective Initiation Reflectivity IF((IGET(709)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=NCI_REFD(I,J)/60.0 ENDDO ENDDO @@ -906,7 +906,7 @@ SUBROUTINE MDL2AGL !--- Convective Activity Reflectivity IF((IGET(710)>0) )THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=NCA_REFD(I,J)/60.0 ENDDO ENDDO @@ -946,7 +946,7 @@ SUBROUTINE MDL2AGL jj=(jsta+jend)/2 ii=(im)/2 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend UAGL(I,J) = SPVAL VAGL(I,J) = SPVAL ! @@ -1123,7 +1123,7 @@ SUBROUTINE MDL2AGL !--- Wind Shear (wind speed difference in knots between sfc and 2000 ft) DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -1175,7 +1175,7 @@ SUBROUTINE MDL2AGL jj = float(jsta+jend)/2.0 ii = float(im)/3.0 DO J=JSTA_2L,JEND_2U - DO I=isx,iex + DO I=ista,iend ! PAGL(I,J) = SPVAL TAGL(I,J) = SPVAL @@ -1219,7 +1219,7 @@ SUBROUTINE MDL2AGL !chc J=JHOLD(NN) ! DO 220 J=JSTA,JEND DO 240 J=JSTA_2L,JEND_2U - DO 240 I=isx,iex + DO 240 I=ista,iend LL = NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -1290,7 +1290,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=isx,iex + DO I=ista,iend QAGL(I,J)=QAGL(I,J)/1000.0 PV=QAGL(I,J)*PAGL(I,J)/(EPS*(1-QAGL(I,J)) + QAGL(I,J)) RHO=(1/TAGL(I,J))*(((PAGL(I,J)-PV)/RD) + PV/461.495) @@ -1307,7 +1307,7 @@ SUBROUTINE MDL2AGL !--- U Component of wind IF((IGET(412)>0) ) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=UAGL(I,J) ENDDO ENDDO @@ -1321,7 +1321,7 @@ SUBROUTINE MDL2AGL !--- V Component of wind IF((IGET(413)>0) ) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=VAGL(I,J) ENDDO ENDDO diff --git a/sorc/ncep_post.fd/MDL2P.f b/sorc/ncep_post.fd/MDL2P.f index c1a9cc364..03f67acbd 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -81,7 +81,7 @@ 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,isx,iex + imp_physics,ista,iend use rqstfld_mod, only: IGET, LVLS, ID, IAVBLFLD, LVLSXML use gridspec_mod, only: GRIDTYPE, MAPTYPE, DXVAL use upp_physics, only: FPVSNEW, CALRH @@ -101,7 +101,7 @@ SUBROUTINE MDL2P(iostatusD3D) real,PARAMETER :: CAPA=0.28589641,P1000=1000.E2 LOGICAL IOOMG,IOALL real, dimension(im,jm) :: GRID1, GRID2 - real, dimension(isx:iex,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL & + real, dimension(ista:iend,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL & &, Q2SL, WSL, CFRSL, O3SL, TDSL & &, EGRID1, EGRID2 & &, FSL_OLD, USL_OLD, VSL_OLD & @@ -110,10 +110,11 @@ SUBROUTINE MDL2P(iostatusD3D) REAL, allocatable :: D3DSL(:,:,:), DUSTSL(:,:,:), SMOKESL(:,:,:) ! integer,intent(in) :: iostatusD3D - INTEGER, dimension(isx:iex,jsta_2l:jend_2u) :: NL1X, NL1XF - real, dimension(isx:iex,JSTA_2L:JEND_2U,LSM) :: TPRS, QPRS, FPRS + INTEGER, dimension(ista:iend,jsta_2l:jend_2u) :: NL1X, NL1XF + real, dimension(ista:iend,JSTA_2L:JEND_2U,LSM) :: TPRS, QPRS, FPRS ! INTEGER K, NSMOOTH +! integer ista,iend ! !--- Definition of the following 2D (horizontal) dummy variables ! @@ -131,9 +132,9 @@ SUBROUTINE MDL2P(iostatusD3D) REAL SDUMMY(IM,2) ! SAVE RH, U,V, for Icing, CAT, LLWS computation - REAL SAVRH(isx:iex,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 @@ -142,6 +143,8 @@ SUBROUTINE MDL2P(iostatusD3D) !****************************************************************************** ! ! START MDL2P. + ista=ista + iend=iend ! if (modelname == 'GFS') then zero = 0.0 @@ -153,7 +156,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,l) do l=1,27 do j=1,jm - do i=isx,iex + do i=ista,iend D3DSL(i,j,l) = SPVAL enddo enddo @@ -164,7 +167,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,l) do l=1,nbin_du do j=1,jm - do i=isx,iex + do i=ista,iend DUSTSL(i,j,l) = SPVAL enddo enddo @@ -174,7 +177,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,l) do l=1,nbin_sm do j=1,jm - do i=isx,iex + do i=ista,iend SMOKESL(i,j,l) = SPVAL enddo enddo @@ -248,7 +251,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! !$omp parallel do private(i,j,l) DO J=JSTA_2L,JEND_2U - DO I=isx,iex + DO I=ista,iend TSL(I,J) = SPVAL QSL(I,J) = SPVAL FSL(I,J) = SPVAL @@ -314,7 +317,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$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=isx,iex + DO I=ista,iend !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC !*** HUMIDITY, CLOUD WATER/ICE, OMEGA, WINDS, AND TKE. @@ -782,7 +785,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -867,7 +870,7 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO ! DO J=JSTA,JEND - DO I=isx,iex-MOD(j,2) + DO I=ista,iend-MOD(j,2) LL = NL1X(I,J) !--------------------------------------------------------------------- @@ -922,7 +925,7 @@ SUBROUTINE MDL2P(iostatusD3D) END DO ELSE IF(gridtype=='B')THEN ! B grid wind interpolation DO J=JSTA,JEND_m - DO I=isx,iex-1 + DO I=ista,iend-1 !*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. ! @@ -952,7 +955,7 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO ! DO J=JSTA,JEND_m - DO I=isx,iex-1 + DO I=ista,iend-1 LL = NL1X(I,J) !--------------------------------------------------------------------- @@ -1010,7 +1013,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(NINT(SPL(LP)) == 50000)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend T500(I,J) = TSL(I,J) ENDDO ENDDO @@ -1028,7 +1031,7 @@ SUBROUTINE MDL2P(iostatusD3D) !HC ALPTH=LOG(1.E5) !HC!$omp parallel do private(i,j) !HC DO J=JSTA,JEND -!HC DO I=isx,iex +!HC DO I=ista,iend !HC IF(FSL(I,J) < SPVAL) THEN !HC PSLPIJ=PSLP(I,J) !HC ALPSL=LOG(PSLPIJ) @@ -1052,7 +1055,7 @@ SUBROUTINE MDL2P(iostatusD3D) !HC IF(IGET(023)<=0.AND.LP == LSM)THEN !!$omp parallel do private(i,j) !HC DO J=JSTA,JEND -!HC DO I=isx,iex +!HC DO I=ista,iend !HC IF(Z1000(I,J) < SPVAL) THEN !HC FSL(I,J)=Z1000(I,J)*G !HC ELSE @@ -1080,7 +1083,7 @@ SUBROUTINE MDL2P(iostatusD3D) ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(FSL(I,J) < SPVAL) THEN GRID1(I,J) = FSL(I,J)*GI ELSE @@ -1115,7 +1118,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1131,7 +1134,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(013)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = TSL(I,J) ENDDO ENDDO @@ -1151,7 +1154,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1165,7 +1168,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(910))>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = TSL(I,J)*(1.+0.608*QSL(I,J)) ENDDO ENDDO @@ -1185,7 +1188,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1202,7 +1205,7 @@ SUBROUTINE MDL2P(iostatusD3D) tem = (P1000/spl(lp)) ** capa !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(TSL(I,J) < SPVAL) THEN grid1(I,J) = TSL(I,J) * tem ELSE @@ -1212,7 +1215,7 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO !!$omp parallel do private(i,j) ! DO J=JSTA,JEND -! DO I=isx,iex +! DO I=ista,iend ! EGRID2(I,J) = SPL(LP) ! ENDDO ! ENDDO @@ -1220,7 +1223,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! CALL CALPOT(EGRID2,TSL,EGRID1) !!$omp parallel do private(i,j) ! DO J=JSTA,JEND -! DO I=isx,iex +! DO I=ista,iend ! GRID1(I,J) = EGRID1(I,J) ! ENDDO ! ENDDO @@ -1232,7 +1235,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1256,7 +1259,7 @@ SUBROUTINE MDL2P(iostatusD3D) if ( log1 ) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID2(I,J) = SPL(LP) ENDDO ENDDO @@ -1265,7 +1268,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(EGRID1(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J)*100. ELSE @@ -1288,7 +1291,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1296,7 +1299,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend SAVRH(I,J) = GRID1(I,J) ENDDO ENDDO @@ -1310,7 +1313,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(331)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend CFRSL(I,J) = MIN(MAX(0.0,CFRSL(I,J)),1.0) IF(abs(CFRSL(I,J)-SPVAL) > SMALL) & GRID1(I,J) = CFRSL(I,J)*H100 @@ -1323,7 +1326,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1337,7 +1340,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(015)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID2(I,J) = SPL(LP) ENDDO ENDDO @@ -1345,7 +1348,7 @@ SUBROUTINE MDL2P(iostatusD3D) CALL CALDWP(EGRID2(1,jsta),QSL(1,jsta),EGRID1(1,jsta),TSL(1,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(TSL(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J) ELSE @@ -1360,7 +1363,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1374,7 +1377,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(016)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = QSL(I,J) ENDDO ENDDO @@ -1386,7 +1389,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1400,7 +1403,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(020)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = OSL(I,J) ENDDO ENDDO @@ -1429,7 +1432,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1443,7 +1446,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(284)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = WSL(I,J) ENDDO ENDDO @@ -1454,7 +1457,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1470,7 +1473,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! if(me == 0) print *,'after calmcvgme=',me,'USL=',USL(1:10,JSTA) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1486,7 +1489,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1508,7 +1511,7 @@ SUBROUTINE MDL2P(iostatusD3D) if ( log1 ) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = USL(I,J) GRID2(I,J) = VSL(I,J) ENDDO @@ -1534,7 +1537,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1545,7 +1548,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1561,7 +1564,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! print *,'me=',me,'EGRID1=',EGRID1(1:10,JSTA) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1590,7 +1593,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1603,14 +1606,14 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(086)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID2(I,J) = FSL(I,J)*GI ENDDO ENDDO CALL CALSTRM(EGRID2(1,jsta),EGRID1(1,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(FSL(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J) ELSE @@ -1625,7 +1628,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1639,7 +1642,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(022)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = Q2SL(I,J) ENDDO ENDDO @@ -1650,7 +1653,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1666,7 +1669,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=isx,iex + DO I=ista,iend GRID1(I,J) = QW1(I,J) + QI1(I,J) QI1(I,J) = spval ENDDO @@ -1674,7 +1677,7 @@ SUBROUTINE MDL2P(iostatusD3D) ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = QW1(I,J) ENDDO ENDDO @@ -1686,7 +1689,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1700,7 +1703,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(166)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = QI1(I,J) ENDDO ENDDO @@ -1711,7 +1714,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1724,7 +1727,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(183)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = QR1(I,J) ENDDO ENDDO @@ -1735,7 +1738,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1748,7 +1751,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(184)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = QS1(I,J) ENDDO ENDDO @@ -1759,7 +1762,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1772,7 +1775,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(416)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = QG1(I,J) ENDDO ENDDO @@ -1783,7 +1786,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1797,7 +1800,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(198)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = C1D(I,J) ENDDO ENDDO @@ -1808,7 +1811,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1821,7 +1824,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(263)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = FRIME(I,J) ENDDO ENDDO @@ -1832,7 +1835,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1845,7 +1848,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(294)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RAD(I,J) ENDDO ENDDO @@ -1856,7 +1859,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1869,7 +1872,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(251)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = DBZ1(I,J) ENDDO ENDDO @@ -1880,7 +1883,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1895,7 +1898,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1906,7 +1909,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1922,7 +1925,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(258)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = FSL(I,J)*GI EGRID1(I,J) = SPVAL ENDDO @@ -1932,7 +1935,7 @@ SUBROUTINE MDL2P(iostatusD3D) ,FSL_OLD(1,jsta_2l),EGRID1(1,jsta_2l)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID1(I,J) ! IF(GRID1(I,J) > 3. .OR. GRID1(I,J) < 0.) ! + print*,'bad CAT',i,j,GRID1(I,J) @@ -1945,7 +1948,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1957,7 +1960,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=isx,iex + DO I=ista,iend USL_OLD(I,J) = USL(I,J) VSL_OLD(I,J) = VSL(I,J) FSL_OLD(I,J) = FSL(I,J)*GI @@ -1969,7 +1972,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(268)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = O3SL(I,J) ENDDO ENDDO @@ -1982,7 +1985,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1995,7 +1998,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(738)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = (1./RD)*SMOKESL(I,J,1)*(SPL(LP)/TSL(I,J)) ENDDO ENDDO @@ -2006,7 +2009,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2019,7 +2022,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(438)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = DUSTSL(I,J,1) ENDDO ENDDO @@ -2030,7 +2033,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2042,7 +2045,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(439)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = DUSTSL(I,J,2) ENDDO ENDDO @@ -2053,7 +2056,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2065,7 +2068,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(440)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = DUSTSL(I,J,3) ENDDO ENDDO @@ -2076,7 +2079,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2088,7 +2091,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(441)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = DUSTSL(I,J,4) ENDDO ENDDO @@ -2099,7 +2102,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2111,7 +2114,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(442)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = DUSTSL(I,J,5) ENDDO ENDDO @@ -2122,7 +2125,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2138,7 +2141,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(355)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,1) ENDDO ENDDO @@ -2173,7 +2176,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2185,7 +2188,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(354)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,2) ENDDO ENDDO @@ -2220,7 +2223,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2232,7 +2235,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(356)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,3) ENDDO ENDDO @@ -2267,7 +2270,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2279,7 +2282,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(357)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,4) ENDDO ENDDO @@ -2314,7 +2317,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2326,7 +2329,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(358)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,5) ENDDO ENDDO @@ -2361,7 +2364,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2373,7 +2376,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(359)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,6) ENDDO ENDDO @@ -2408,7 +2411,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2420,7 +2423,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(360)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,7) ENDDO ENDDO @@ -2455,7 +2458,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2467,7 +2470,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(361)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,8) ENDDO ENDDO @@ -2502,7 +2505,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2514,7 +2517,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(362)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,9) ENDDO ENDDO @@ -2549,7 +2552,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2561,7 +2564,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(363)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,10) ENDDO ENDDO @@ -2597,7 +2600,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2609,7 +2612,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(364)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,11) ENDDO ENDDO @@ -2645,7 +2648,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2657,7 +2660,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(365)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,12) ENDDO ENDDO @@ -2693,7 +2696,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2705,7 +2708,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(366)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,13) ENDDO ENDDO @@ -2741,7 +2744,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2753,7 +2756,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(367)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,14) ENDDO ENDDO @@ -2789,7 +2792,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2801,7 +2804,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(368)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,15) ENDDO ENDDO @@ -2837,7 +2840,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2849,7 +2852,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(369)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,16) ENDDO ENDDO @@ -2884,7 +2887,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2896,7 +2899,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(370)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,17) ENDDO ENDDO @@ -2932,7 +2935,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2944,7 +2947,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(371)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,18) ENDDO ENDDO @@ -2980,7 +2983,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2992,7 +2995,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(372)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,19) ENDDO ENDDO @@ -3027,7 +3030,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3039,7 +3042,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(373)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,20) ENDDO ENDDO @@ -3075,7 +3078,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3087,7 +3090,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(374)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,21) ENDDO ENDDO @@ -3123,7 +3126,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3135,7 +3138,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(375)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,22) ENDDO ENDDO @@ -3170,7 +3173,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3182,7 +3185,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(379)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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) & @@ -3223,7 +3226,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3235,7 +3238,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(391)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,23) ENDDO ENDDO @@ -3271,7 +3274,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3283,7 +3286,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(392)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,24) ENDDO ENDDO @@ -3319,7 +3322,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3331,7 +3334,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(393)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,25) ENDDO ENDDO @@ -3367,7 +3370,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3379,7 +3382,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(394)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,26) ENDDO ENDDO @@ -3415,7 +3418,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3427,7 +3430,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(395)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = D3DSL(i,j,27) ENDDO ENDDO @@ -3463,7 +3466,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3482,7 +3485,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! print*,'computing dew point for Haine Index at ',SPL(LP) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend HAINES(i,j) = SPVAL EGRID2(I,J) = SPL(LP) ENDDO @@ -3491,15 +3494,15 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,dum1,ista,imois) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(SM(I,J) < 1.0 .AND. ZINT(I,J,LM+1) < FSL(I,J)*GI) THEN DUM1 = TSL(I,J)-TPRS(I,J,LUHI) IF(DUM1 <= 17.)THEN - ISTA = 1 + ISTAA = 1 ELSE IF(DUM1 > 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 @@ -3509,7 +3512,7 @@ SUBROUTINE MDL2P(iostatusD3D) ELSE IMOIS = 3 END IF - HAINES(I,J) = ISTA + IMOIS + HAINES(I,J) = ISTAA + IMOIS ! if(i==570 .and. j==574)print*,'high hainesindex:',i,j,luhi,tsl(i,j) & ! ,tprs(i,j,luhi),tdsl(i,j),ista,imois,spl(luhi),spl(lp),haines(i,j) END IF @@ -3523,7 +3526,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! print*,'computing dew point for Haine Index at ',SPL(LP) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID2(I,J) = SPL(LP) ENDDO ENDDO @@ -3531,15 +3534,15 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,dum1,ista,imois) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(SM(I,J) < 1.0 .AND. ZINT(I,J,LM+1) < FSL(I,J)*GI) THEN DUM1 = TSL(I,J)-TPRS(I,J,LUHI) IF(DUM1 <=5. ) THEN - ISTA = 1 + ISTAA = 1 ELSE IF(DUM1 > 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 @@ -3551,7 +3554,7 @@ SUBROUTINE MDL2P(iostatusD3D) END IF ! 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) - HAINES(I,J) = ISTA + IMOIS + HAINES(I,J) = ISTAA + IMOIS END IF END DO END DO @@ -3563,7 +3566,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! print*,'computing dew point for Haine Index at ',SPL(LP) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID2(I,J)=SPL(LP) ENDDO ENDDO @@ -3571,15 +3574,15 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,dum1,ista,imois) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(SM(I,J) < 1.0 .AND. ZINT(I,J,LM+1) < FSL(I,J)*GI) THEN DUM1 = TSL(I,J)-TPRS(I,J,LUHI) IF(DUM1 <= 3.)THEN - ISTA = 1 + ISTAA = 1 ELSE IF(DUM1 > 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 @@ -3590,8 +3593,8 @@ SUBROUTINE MDL2P(iostatusD3D) IMOIS = 3 END IF ! 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) - HAINES(I,J) = ISTA + IMOIS +! ,tprs(i,j,luhi),tdsl(i,j),istaa,imois,spl(luhi),spl(lp),haines(i,j) + HAINES(I,J) = ISTAA + IMOIS END IF END DO END DO @@ -3602,7 +3605,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = HAINES(i,jj) enddo enddo @@ -3624,7 +3627,7 @@ SUBROUTINE MDL2P(iostatusD3D) LP=46 ! 1000 MB !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = W_UP_MAX(I,J) ! print *,' writing w_up_max, i,j, = ', w_up_max(i,j) ENDDO @@ -3642,7 +3645,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3655,7 +3658,7 @@ SUBROUTINE MDL2P(iostatusD3D) LP = 46 ! 1000 MB !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = W_DN_MAX(I,J) ENDDO ENDDO @@ -3672,7 +3675,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3690,7 +3693,7 @@ SUBROUTINE MDL2P(iostatusD3D) LP = 46 ! 1000 MB !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = W_MEAN(I,J) ENDDO ENDDO @@ -3707,7 +3710,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3733,7 +3736,7 @@ SUBROUTINE MDL2P(iostatusD3D) END IF !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PSLP(I,J) ENDDO ENDDO @@ -3745,7 +3748,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3758,7 +3761,7 @@ SUBROUTINE MDL2P(iostatusD3D) CALL MAPSSLP(TPRS) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PSLP(I,J) ENDDO ENDDO @@ -3768,7 +3771,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3790,14 +3793,14 @@ 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=isx,iex + DO I=ista,iend GRID1(I,J) = FSL(I,J)*GI ENDDO ENDDO ELSE !$omp parallel do private(i,j,PSLPIJ,ALPSL,PSFC) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(PSLP(I,J) < spval) THEN PSLPIJ = PSLP(I,J) ALPSL = LOG(PSLPIJ) @@ -3830,7 +3833,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo diff --git a/sorc/ncep_post.fd/MDL2SIGMA.f b/sorc/ncep_post.fd/MDL2SIGMA.f index fa0e5a972..6a29ac6b7 100644 --- a/sorc/ncep_post.fd/MDL2SIGMA.f +++ b/sorc/ncep_post.fd/MDL2SIGMA.f @@ -61,7 +61,7 @@ SUBROUTINE MDL2SIGMA h1m12, d00, h2, rd, g, gi, h99999 use ctlblk_mod, only: jsta_2l, jend_2u, spval, lp1, jsta, jend, lm, & grib, cfld, datapd, fld_info, me, jend_m, im, & - jm, im_jm,isx,iex + jm, im_jm,ista,iend use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml use gridspec_mod, only :gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -80,7 +80,7 @@ SUBROUTINE MDL2SIGMA LOGICAL IOOMG,IOALL LOGICAL DONEFSL1,TSLDONE ! real, dimension(im,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL, Q2SL, & - real, dimension(isx:iex,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL, Q2SL, & + real, dimension(ista:iend,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL, Q2SL, & FSL1, CFRSIG, EGRID1, EGRID2 REAL GRID1(IM,JM),GRID2(IM,JM) REAL SIGO(LSIG+1),DSIGO(LSIG),ASIGO(LSIG) @@ -96,7 +96,7 @@ SUBROUTINE MDL2SIGMA ! QR1 - rain mixing ratio ! QS1 - snow mixing ratio ! - real, dimension(isx:iex,jsta_2l:jend_2u) :: C1D, QW1, QI1, QR1, QS1, QG1, AKH + real, dimension(ista:iend,jsta_2l:jend_2u) :: C1D, QW1, QI1, QR1, QS1, QG1, AKH ! integer I,J,L,LL,LP,LLMH,II,JJ,JJB,JJE,NHOLD real PFSIGO,APFSIGO,PSIGO,APSIGO,PNL1,PU,ZU,TU,QU,QSAT, & @@ -194,7 +194,7 @@ SUBROUTINE MDL2SIGMA END IF ! OBTAIN GEOPOTENTIAL AT 1ST LEVEL DO J=JSTA_2L,JEND_2U - DO I=isx,iex + DO I=ista,iend FSL(I,J)=SPVAL AKH(I,J)=SPVAL NL1XF(I,J)=LP1 @@ -206,7 +206,7 @@ SUBROUTINE MDL2SIGMA END DO END DO DO 167 J=JSTA,JEND - DO 167 I=isx,iex + DO 167 I=ista,iend DONEFSL1=.FALSE. PFSIGO=PTSIGO APFSIGO=LOG(PFSIGO) @@ -307,7 +307,7 @@ SUBROUTINE MDL2SIGMA IF (LVLS(1,IGET(205))>0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(FSL1(I,J)0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=isx,iex + 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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif if(me==0)print*,'output Heat Diffusivity' @@ -351,7 +351,7 @@ SUBROUTINE MDL2SIGMA NHOLD=0 ! DO J=JSTA_2L,JEND_2U - DO I=isx,iex + DO I=ista,iend ! TSL(I,J)=SPVAL @@ -405,7 +405,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=isx,iex + DO 220 I=ista,iend LL=NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -553,7 +553,7 @@ SUBROUTINE MDL2SIGMA ! ! OBTAIN GEOPOTENTIAL AND KH ON INTERFACES DO J=JSTA_2L,JEND_2U - DO I=isx,iex + DO I=ista,iend FSL(I,J)=SPVAL AKH(I,J)=SPVAL NL1XF(I,J)=LP1 @@ -569,7 +569,7 @@ SUBROUTINE MDL2SIGMA ! ! DO J=JSTA_2L,JEND_2U DO J=JSTA,JEND ! Moorthi on 26 Nov 2014 - DO I=isx,iex + DO I=ista,iend DONEFSL1=.FALSE. TSLDONE=.FALSE. LLMH = NINT(LMH(I,J)) @@ -719,10 +719,10 @@ SUBROUTINE MDL2SIGMA ! VERTICAL INTERPOLATION FOR WIND FOR E and B GRIDS ! if(gridtype=='B' .or. gridtype=='E') & - call exch(PINT(isx:iex,JSTA_2L:JEND_2U,LP1)) + call exch(PINT(ista:iend,JSTA_2L:JEND_2U,LP1)) IF(gridtype=='E')THEN DO J=JSTA,JEND - DO I=isx,iex-MOD(J,2) + DO I=ista,iend-MOD(J,2) ! !*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. @@ -764,7 +764,7 @@ SUBROUTINE MDL2SIGMA ENDDO ! DO 230 J=JSTA,JEND - DO 230 I=isx,iex-MOD(j,2) + DO 230 I=ista,iend-MOD(j,2) LLMH = NINT(LMH(I,J)) IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC PDV=0.5*(PINT(I,J,LLMH+1)+PINT(I+1,J,LLMH+1)) @@ -827,7 +827,7 @@ SUBROUTINE MDL2SIGMA ELSE IF (gridtype=='B')THEN DO J=JSTA,JEND_M - DO I=isx,iex-1 + DO I=ista,iend-1 ! !*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. @@ -856,7 +856,7 @@ SUBROUTINE MDL2SIGMA ENDDO ! DO 231 J=JSTA,JEND_M - DO 231 I=isx,iex-1 + DO 231 I=ista,iend-1 PDV=0.25*(PINT(I,J,LP1)+PINT(I+1,J,LP1) & +PINT(I,J+1,LP1)+PINT(I+1,J+1,LP1)) PSIGO=PTSIGO+ASIGO(LP)*(PDV-PTSIGO) @@ -927,7 +927,7 @@ SUBROUTINE MDL2SIGMA IF(LVLS(LP+1,IGET(205))>0)THEN !$omp parallel do DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(FSL(I,J)0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -960,7 +960,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(243)) fld_info(cfld)%lvl=LVLSXML(LP+1,IGET(243)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif if(me==0)print*,'output Heat Diffusivity' ENDIF @@ -971,7 +971,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(206)>0) THEN IF(LVLS(LP,IGET(206))>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=TSL(I,J) ENDDO ENDDO @@ -979,7 +979,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(206)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(206)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -990,7 +990,7 @@ SUBROUTINE MDL2SIGMA IF(LVLS(LP,IGET(216))>0)THEN !$omp parallel do DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend LLMH = NINT(LMH(I,J)) GRID1(I,J)=PTSIGO+ASIGO(LP)*(PINT(I,J,LLMH+1)-PTSIGO) ENDDO @@ -999,7 +999,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(216)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(216)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1009,7 +1009,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(207)>0)THEN IF(LVLS(LP,IGET(207))>0)THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=QSL(I,J) ENDDO ENDDO @@ -1018,7 +1018,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(207)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(207)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1028,7 +1028,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(210)>0)THEN IF(LVLS(LP,IGET(210))>0)THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=OSL(I,J) ENDDO ENDDO @@ -1036,7 +1036,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(210)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(210)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1046,7 +1046,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=isx,iex + DO I=ista,iend GRID1(I,J)=USL(I,J) GRID2(I,J)=VSL(I,J) ENDDO @@ -1055,11 +1055,11 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(208)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(208)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,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(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1069,7 +1069,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(217)>0) THEN IF (LVLS(LP,IGET(217))>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=Q2SL(I,J) ENDDO ENDDO @@ -1077,7 +1077,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(217)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(217)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1087,7 +1087,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(211)>0) THEN IF (LVLS(LP,IGET(211))>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=QW1(I,J) ENDDO ENDDO @@ -1095,7 +1095,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(211)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(211)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1105,7 +1105,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(212)>0) THEN IF (LVLS(LP,IGET(212))>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=QI1(I,J) ENDDO ENDDO @@ -1113,7 +1113,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(212)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(212)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1122,7 +1122,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(213)>0) THEN IF (LVLS(LP,IGET(213))>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=QR1(I,J) ENDDO ENDDO @@ -1130,7 +1130,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(213)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(213)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1139,7 +1139,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(214)>0) THEN IF (LVLS(LP,IGET(214))>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=QS1(I,J) ENDDO ENDDO @@ -1147,7 +1147,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(214)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(214)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1156,7 +1156,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(255)>0) THEN IF (LVLS(LP,IGET(255))>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=QG1(I,J) ENDDO ENDDO @@ -1164,7 +1164,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(255)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(255)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1173,7 +1173,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(215)>0) THEN IF (LVLS(LP,IGET(215))>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=C1D(I,J) ENDDO ENDDO @@ -1181,7 +1181,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(215)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(215)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1190,7 +1190,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(222)>0) THEN IF (LVLS(LP,IGET(222))>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=CFRSIG(I,J) ENDDO ENDDO @@ -1198,7 +1198,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(222)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(222)) - datapd(isx:iex,1:jend-jsta+1,cfld)=GRID1(isx:iex,jsta:jend) + datapd(ista:iend,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 f1449b17d..2529e9712 100644 --- a/sorc/ncep_post.fd/MDL2SIGMA2.f +++ b/sorc/ncep_post.fd/MDL2SIGMA2.f @@ -48,7 +48,7 @@ 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,isx,iex + grib, cfld, datapd, fld_info, im, jm, im_jm,ista,iend use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml ! implicit none @@ -59,12 +59,12 @@ SUBROUTINE MDL2SIGMA2 ! LOGICAL READTHK ! REAL,dimension(im,jm) :: FSL, TSL, QSL, osl, usl, vsl, q2sl, fsl1, & - REAL,dimension(isx:iex,jsta_2l:jend_2u) :: TSL + REAL,dimension(ista:iend,jsta_2l:jend_2u) :: TSL REAL,dimension(im,jm) :: grid1 REAL SIGO(LSIG+1),DSIGO(LSIG),ASIGO(LSIG) ! ! INTEGER,dimension(im,jm) :: IHOLD,JHOLD,NL1X,NL1XF - INTEGER,dimension(isx:iex,jsta_2l:jend_2u) :: NL1X + INTEGER,dimension(ista:iend,jsta_2l:jend_2u) :: NL1X ! ! !--- Definition of the following 2D (horizontal) dummy variables @@ -132,7 +132,7 @@ SUBROUTINE MDL2SIGMA2 NHOLD=0 ! DO J=JSTA_2L,JEND_2U - DO I=isx,iex + DO I=ista,iend ! TSL(I,J)=SPVAL @@ -173,7 +173,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=isx,iex + DO 220 I=ista,iend LL=NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -261,7 +261,7 @@ SUBROUTINE MDL2SIGMA2 IF(IGET(296)>0) THEN IF(LVLS(LP,IGET(296))>0)THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=TSL(I,J) ENDDO ENDDO diff --git a/sorc/ncep_post.fd/MDLFLD.f b/sorc/ncep_post.fd/MDLFLD.f index d464939f3..11c6b5e07 100644 --- a/sorc/ncep_post.fd/MDLFLD.f +++ b/sorc/ncep_post.fd/MDLFLD.f @@ -95,7 +95,7 @@ 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,isx,iex + me, dt, avrain, theat, ifhr, ifmin, avcnvc, lp1, im, jm,ista,iend use rqstfld_mod, only: iget, id, lvls, iavblfld, lvlsxml use gridspec_mod, only: gridtype,maptype,dxval use upp_physics, only: CALRH, CALCAPE @@ -127,7 +127,7 @@ SUBROUTINE MDLFLD LOGICAL NMM_GFSmicro LOGiCAL Model_Radar real, dimension(im,jm) :: GRID1, GRID2 - real, dimension(isx:iex,jsta_2l:jend_2u) :: EGRID1, EGRID2, EGRID3, EGRID4, EGRID5,& + real, dimension(ista:iend,jsta_2l:jend_2u) :: EGRID1, EGRID2, EGRID3, EGRID4, EGRID5,& EL0, P1D, T1D, Q1D, C1D, & FI1D, FR1D, FS1D, QW1, QI1, & QR1, QS1, CUREFL_S, & @@ -158,8 +158,8 @@ SUBROUTINE MDLFLD integer ks,nsmooth REAL SDUMMY(IM,2),dxm ! added to calculate cape and cin for icing - real, dimension(isx:iex,jsta:jend) :: dummy, cape, cin - integer idummy(isx:iex,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. @@ -184,7 +184,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=isx,iex + DO I=ista,iend IF(ABS(REF_10CM(I,J,L)-SPVAL)>SMALL) THEN Model_Radar=.True. exit check_ref @@ -194,16 +194,16 @@ 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 (isx:iex,JSTA_2L:JEND_2U,LM)) - ALLOCATE(RICHNO (isx:iex,JSTA_2L:JEND_2U,LM)) - ALLOCATE(PBLRI (isx:iex,JSTA_2L:JEND_2U)) + ALLOCATE(EL (ista:iend,JSTA_2L:JEND_2U,LM)) + ALLOCATE(RICHNO (ista:iend,JSTA_2L:JEND_2U,LM)) + ALLOCATE(PBLRI (ista:iend,JSTA_2L:JEND_2U)) ! ! SECOND, STANDARD NGM SEA LEVEL PRESSURE. IF (IGET(105) > 0) THEN CALL NGMSLP !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SLP(I,J) ENDDO ENDDO @@ -213,7 +213,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -229,7 +229,7 @@ SUBROUTINE MDLFLD ! print*,'DTQ2 in MDLFLD= ',DTQ2 RDTPHS=24.*3.6E6/DTQ2 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF ((HBOT(I,J)-HTOP(I,J)) <= 1.0) THEN ICBOT(I,J)=0 ICTOP(I,J)=0 @@ -257,7 +257,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=isx,iex + ENDDO !--- DO I=ista,iend ENDDO !--- DO J=JSTA,JEND ENDIF !-- IF (MODELNAME=='NMM' .OR. imp_physics==5) THEN ! @@ -275,7 +275,7 @@ SUBROUTINE MDLFLD .or. NMM_GFSmicro)THEN RDTPHS=3.6E6/DTQ2 DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -311,7 +311,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=isx,iex + 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) @@ -364,7 +364,7 @@ SUBROUTINE MDLFLD refl_miss: IF (Model_Radar) THEN ! - Model output DBZ is present - proceed with calc DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend ze_nc=10.**(0.1*REF_10CM(I,J,L)) DBZ1(I,J)=10.*LOG10(max(Zmin,(ze_nc+CUREFL(I,J)))) DBZR1(I,J)=MIN(DBZR1(I,J), REF_10CM(I,J,L)) @@ -426,7 +426,7 @@ SUBROUTINE MDLFLD !--- This branch is executed if GFS micro (imp_physics=9) is run in the NMM. ! DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend QI1(I,J)=C1D(I,J)*FI1D(I,J) QW1(I,J)=C1D(I,J)-QI1(I,J) QR1(I,J)=D00 @@ -439,7 +439,7 @@ SUBROUTINE MDLFLD ENDDO ENDIF DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend LLMH = NINT(LMH(I,J)) IF (L > LLMH) THEN QQW(I,J,L) = D00 @@ -481,7 +481,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=isx,iex + DO I=ista,iend LLMH = NINT(LMH(I,J)) IF (L > LLMH) THEN QQW(I,J,L) = D00 @@ -509,7 +509,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=isx,iex + DO I=ista,iend LLMH = NINT(LMH(I,J)) IF (L > LLMH) THEN QQW(I,J,L)=D00 @@ -549,7 +549,7 @@ SUBROUTINE MDLFLD .and. imp_physics==8)THEN !NMMB or FV3R +THOMPSON DO L=1,LM DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend DBZ(I,J,L)=REF_10CM(I,J,L) ENDDO ENDDO @@ -557,7 +557,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=isx,iex + DO I=ista,iend DBZ(I,J,L)=SPVAL ENDDO ENDDO @@ -575,7 +575,7 @@ SUBROUTINE MDLFLD ! Chuang: add convective contribution for all MP schemes RDTPHS=3.6E6/DTQ2 DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -607,7 +607,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=isx,iex + DO I=ista,iend !--- Estimate radar reflectivity factor from convection at level L ! CUREFL(I,J)=0. @@ -717,7 +717,7 @@ SUBROUTINE MDLFLD ze_gmax = -1.E30 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend refl(i,j) = -10. ze_max = -10. @@ -860,7 +860,7 @@ SUBROUTINE MDLFLD ! ABSOLUTE VORTICITY ON MDL SURFACES. ! ! - allocate (RH3D(isx:iex,jsta_2l:jend_2u,lm)) + allocate (RH3D(ista:iend,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. & @@ -895,7 +895,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PMID(I,J,LL) ENDDO ENDDO @@ -906,7 +906,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -922,7 +922,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = QQW(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -934,7 +934,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -949,7 +949,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j,jj) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = QQI(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -961,7 +961,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -976,7 +976,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = QQR(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -988,7 +988,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1003,7 +1003,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = QQS(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -1015,7 +1015,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1030,7 +1030,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -1042,7 +1042,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1057,7 +1057,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -1069,7 +1069,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1084,7 +1084,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -1096,7 +1096,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1111,7 +1111,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -1123,7 +1123,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1136,7 +1136,7 @@ SUBROUTINE MDLFLD IF (LVLS(L,IGET(766)) > 0)THEN LL=LM-L+1 DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -1156,7 +1156,7 @@ SUBROUTINE MDLFLD IF (LVLS(L,IGET(767)) > 0)THEN LL=LM-L+1 DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -1177,7 +1177,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(abs(CFR(I,J,LL)-SPVAL) > SMALL) & & GRID1(I,J) = CFR(I,J,LL)*H100 ENDDO @@ -1190,7 +1190,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1205,7 +1205,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(MODELNAME == 'RAPR') THEN GRID1(I,J) = CFR(I,J,LL) ELSE @@ -1220,7 +1220,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1244,14 +1244,14 @@ SUBROUTINE MDLFLD IF(IMP_PHYSICS == 8 .or. IMP_PHYSICS == 28) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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=isx,iex + DO I=ista,iend GRID1(I,J) = DBZ(I,J,LL) ENDDO ENDDO @@ -1265,7 +1265,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1281,7 +1281,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = CWM(I,J,LL) ENDDO ENDDO @@ -1292,7 +1292,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1307,7 +1307,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = F_rain(I,J,LL) ENDDO ENDDO @@ -1318,7 +1318,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1333,7 +1333,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = F_ice(I,J,LL) ENDDO ENDDO @@ -1344,7 +1344,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1360,7 +1360,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = F_RimeF(I,J,LL) ENDDO ENDDO @@ -1371,7 +1371,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1386,7 +1386,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = ZMID(I,J,LL) ENDDO ENDDO @@ -1397,7 +1397,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1412,7 +1412,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = T(I,J,LL) ENDDO ENDDO @@ -1423,7 +1423,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1438,7 +1438,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=T(I,J,LL)*(1.+D608*Q(I,J,LL)) ENDDO ENDDO @@ -1458,7 +1458,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend P1D(I,J) = PMID(I,J,LL) T1D(I,J) = T(I,J,LL) ENDDO @@ -1467,7 +1467,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -1478,7 +1478,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1493,7 +1493,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend P1D(I,J) = PMID(I,J,LL) T1D(I,J) = T(I,J,LL) ENDDO @@ -1502,7 +1502,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID3(I,J) * (1.+D608*Q(I,J,LL)) ENDDO ENDDO @@ -1513,7 +1513,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1529,7 +1529,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -1540,7 +1540,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID4(I,J)*100. RH3D(I,J,LL) = GRID1(I,J) EGRID2(I,J) = Q(I,J,LL)/max(1.e-8,EGRID4(I,J)) ! Revert QS to compute cloud cover later @@ -1554,7 +1554,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1569,7 +1569,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -1578,7 +1578,7 @@ SUBROUTINE MDLFLD CALL CALDWP(P1D(1,jsta),Q1D(1,jsta),EGRID3(1,jsta),T1D(1,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -1589,7 +1589,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1603,7 +1603,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = Q(I,J,LL) ENDDO ENDDO @@ -1615,7 +1615,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1629,7 +1629,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = Q(I,J,LL) / (1.-Q(I,J,LL)) ENDDO ENDDO @@ -1641,7 +1641,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1658,7 +1658,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=isx,iex + DO I=ista,iend Q1D(I,J) = Q(I,J,LL) EGRID1(I,J) = UH(I,J,LL) EGRID2(I,J) = VH(I,J,LL) @@ -1667,7 +1667,7 @@ SUBROUTINE MDLFLD CALL CALMCVG(Q1D,EGRID1,EGRID2,EGRID3) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID3(I,J) MCVG(I,J,LL) = EGRID3(I,J) ENDDO @@ -1680,7 +1680,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1696,7 +1696,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = UH(I,J,LL) GRID2(I,J) = VH(I,J,LL) ENDDO @@ -1708,7 +1708,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1718,7 +1718,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1732,7 +1732,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = OMGA(I,J,LL) ENDDO ENDDO @@ -1743,7 +1743,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1757,7 +1757,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=WH(I,J,LL) ENDDO ENDDO @@ -1768,7 +1768,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1782,7 +1782,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=isx,iex + DO I=ista,iend EGRID1(I,J) = UH(I,J,LL) EGRID2(I,J) = VH(I,J,LL) ENDDO @@ -1790,7 +1790,7 @@ SUBROUTINE MDLFLD CALL CALVOR(EGRID1,EGRID2,EGRID3) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -1801,7 +1801,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1815,14 +1815,14 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID1(I,J) = ZMID(I,J,LL) ENDDO ENDDO CALL CALSTRM(EGRID1(1,jsta),EGRID2(1,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID2(I,J) ENDDO ENDDO @@ -1833,7 +1833,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1847,7 +1847,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = Q2(I,J,LL) ENDDO ENDDO @@ -1858,7 +1858,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1870,14 +1870,14 @@ SUBROUTINE MDLFLD !HC IF (IGET(124)>0) THEN !HC IF (LVLS(L,IGET(124))>0) THEN !HC DO J=JSTA,JEND -!HC DO I=isx,iex +!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,GRIDisx,iex,JM) +!HC CALL GRIBIT(IGET(124),L,GRIDista,iend,JM) !HC ENDIF !HC ENDIF ! @@ -1886,12 +1886,12 @@ SUBROUTINE MDLFLD ! IF (IGET(125)>0) THEN ! IF (LVLS(L,IGET(125))>0) THEN ! DO J=JSTA,JEND -! DO I=isx,iex +! DO I=ista,iend ! GRID1(I,J)=QICE(I,J,L) ! ENDDO ! ENDDO ! ID(1:25) = 0 -! CALL GRIBIT(IGET(125),L,GRIDisx,iex,JM) +! CALL GRIBIT(IGET(125),L,GRIDista,iend,JM) ! ENDIF ! ENDIF ! @@ -1901,12 +1901,12 @@ SUBROUTINE MDLFLD ! IF (IGET(145)>0) THEN ! IF (LVLS(L,IGET(145))>0) THEN ! DO J=JSTA,JEND -! DO I=isx,iex +! DO I=ista,iend ! GRID1(I,J)=CFRC(I,J,L) ! ENDDO ! ENDDO ! ID(1:25) = 0 -! CALL GRIBIT(IGET(145),L,GRIDisx,iex,JM) +! CALL GRIBIT(IGET(145),L,GRIDista,iend,JM) ! ENDIF ! ENDIF ! @@ -1917,7 +1917,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = TTND(I,J,LL) ENDDO ENDDO @@ -1928,7 +1928,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1943,7 +1943,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RSWTT(I,J,LL) ENDDO ENDDO @@ -1954,7 +1954,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1969,7 +1969,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RLWTT(I,J,LL) ENDDO ENDDO @@ -1980,7 +1980,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2002,7 +2002,7 @@ SUBROUTINE MDLFLD ENDIF !$omp parallel do DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = TRAIN(I,J,LL)*RRNUM ENDDO ENDDO @@ -2035,7 +2035,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2054,7 +2054,7 @@ SUBROUTINE MDLFLD ENDIF !$omp parallel do DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = TCUCN(I,J,LL)*RRNUM ENDDO ENDDO @@ -2087,7 +2087,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2101,7 +2101,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = O3(I,J,LL) ENDDO ENDDO @@ -2112,7 +2112,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2127,7 +2127,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = (1./RD)*(PMID(I,J,LL)/T(I,J,LL))*SMOKE(I,J,LL,1) ENDDO ENDDO @@ -2138,7 +2138,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2152,7 +2152,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend !GRID1(I,J) = DUST(I,J,LL,1) GRID1(I,J) = DUST(I,J,LL,1)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO @@ -2164,7 +2164,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2178,7 +2178,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend !GRID1(I,J) = DUST(I,J,LL,2) GRID1(I,J) = DUST(I,J,LL,2)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO @@ -2190,7 +2190,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2204,7 +2204,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend !GRID1(I,J) = DUST(I,J,LL,3) GRID1(I,J) = DUST(I,J,LL,3)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO @@ -2216,7 +2216,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2230,7 +2230,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend !GRID1(I,J) = DUST(I,J,LL,4) GRID1(I,J) = DUST(I,J,LL,4)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO @@ -2242,7 +2242,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2256,7 +2256,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend !GRID1(I,J) = DUST(I,J,LL,5) GRID1(I,J) = DUST(I,J,LL,5)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO @@ -2268,7 +2268,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2282,7 +2282,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SALT(I,J,LL,1)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO ENDDO @@ -2293,7 +2293,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2307,7 +2307,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SALT(I,J,LL,2)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO ENDDO @@ -2318,7 +2318,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2332,7 +2332,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SALT(I,J,LL,3)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO ENDDO @@ -2343,7 +2343,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2357,7 +2357,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SALT(I,J,LL,4)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO ENDDO @@ -2368,7 +2368,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2382,7 +2382,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SALT(I,J,LL,5)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO ENDDO @@ -2393,7 +2393,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2407,7 +2407,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend !GRID1(I,J) = SUSO(I,J,LL,1) GRID1(I,J) = SUSO(I,J,LL,1)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 ENDDO @@ -2419,7 +2419,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2433,7 +2433,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend !GRID1(I,J) = WASO(I,J,LL,1) GRID1(I,J) = WASO(I,J,LL,1)*RHOMID(I,J,LL) !lzhang ENDDO @@ -2445,7 +2445,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2459,7 +2459,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend !GRID1(I,J) = WASO(I,J,LL,2) GRID1(I,J) = WASO(I,J,LL,2)*RHOMID(I,J,LL) !lzhang ENDDO @@ -2471,7 +2471,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2485,7 +2485,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend !GRID1(I,J) = SOOT(I,J,LL,1) GRID1(I,J) = SOOT(I,J,LL,1)*RHOMID(I,J,LL) !lzhang ENDDO @@ -2497,7 +2497,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2511,7 +2511,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend !GRID1(I,J) = SOOT(I,J,LL,2) GRID1(I,J) = SOOT(I,J,LL,2)*RHOMID(I,J,LL) !lzhang ENDDO @@ -2523,7 +2523,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2537,7 +2537,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RHOMID(I,J,LL) ENDDO ENDDO @@ -2548,7 +2548,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2562,7 +2562,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = DPRES(I,J,LL) ENDDO ENDDO @@ -2573,7 +2573,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2601,7 +2601,7 @@ SUBROUTINE MDLFLD !MEB Eta-specific code ! NEED TO CALCULATE RAIN WATER AND SNOW MIXING RATIOS ! DO J=JSTA,JEND -! DO I=isx,iex +! DO I=ista,iend !MEB IF (PREC(I,J)==0) THEN !MEB QSNO(I,J)=0. !MEB QRAIN(I,J)=0. @@ -2630,13 +2630,13 @@ SUBROUTINE MDLFLD ! ENDDO ! CALL CALVIS(QV,QCD,QRAIN1,QICE1,QSNO1,TT,PPP,VIS) ! DO J=JSTA,JEND -! DO I=isx,iex +! DO I=ista,iend ! GRID1(I,J)=VIS(I,J) ! ENDDO ! ENDDO ! ID(1:25) = 0 ! CALL GRIBIT(IGET(180),LVLS(1,IGET(180)), -! X GRIDisx,iex,JM) +! X GRIDista,iend,JM) ! ENDIF ! ! INSTANTANEOUS CONVECTIVE PRECIPITATION RATE. @@ -2644,13 +2644,13 @@ SUBROUTINE MDLFLD ! IF (IGET(249)>0) THEN ! RDTPHS=1000./DTQ2 ! DO J=JSTA,JEND -! DO I=isx,iex +! 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,GRIDisx,iex,JM) +! CALL GRIBIT(IGET(249),LM,GRIDista,iend,JM) ! ENDIF ! ! COMPOSITE RADAR REFLECTIVITY (maximum dBZ in each column) @@ -2659,7 +2659,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=isx,iex + 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) ) @@ -2679,7 +2679,7 @@ SUBROUTINE MDLFLD MODELNAME=='NMM' .and. gridtype=='E')THEN !$omp parallel do private(i,j,l) DO J=JSTA,JEND - DO I=isx,iex + 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) ) @@ -2689,7 +2689,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = REFC_10CM(I,J) ENDDO ENDDO @@ -2698,7 +2698,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = refl(i,j) ENDDO ENDDO @@ -2711,7 +2711,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2723,7 +2723,7 @@ SUBROUTINE MDLFLD ! on emprical conversion factors (0.00344) IF (IGET(581)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=0.0 DO L=1,NINT(LMH(I,J)) if(zint(i,j,l) < spval) then @@ -2739,7 +2739,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2750,7 +2750,7 @@ SUBROUTINE MDLFLD ! IF (IGET(276)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + 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) ) @@ -2763,7 +2763,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2775,7 +2775,7 @@ SUBROUTINE MDLFLD ! IF (IGET(277)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + 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) ) @@ -2788,7 +2788,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2802,7 +2802,7 @@ SUBROUTINE MDLFLD ! IF (IGET(278)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + 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) ) @@ -2815,7 +2815,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2828,7 +2828,7 @@ SUBROUTINE MDLFLD IF (IGET(426)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=0.0 DO L=1,NINT(LMH(I,J)) IF (DBZ(I,J,L)>=18.0) THEN @@ -2844,7 +2844,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2863,7 +2863,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=isx,iex + DO I=ista,iend GRID1(I,J) = -999. DO L=1,NINT(LMH(I,J)) IF (REF_10CM(I,J,L)>=18.0) THEN @@ -2892,7 +2892,7 @@ SUBROUTINE MDLFLD ENDDO ELSE DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = -999. DO L=1,NINT(LMH(I,J)) IF (DBZ(I,J,L) >= 18.0) THEN @@ -2909,7 +2909,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2920,7 +2920,7 @@ SUBROUTINE MDLFLD ! IF (IGET(769)>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=0.0 DO L=1,NINT(LMH(I,J)) GRID1(I,J)=GRID1(I,J) + (QQR(I,J,L) + & @@ -2936,7 +2936,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2950,7 +2950,7 @@ SUBROUTINE MDLFLD IF (IGET(770) > 0) THEN IF(MODELNAME == 'RAPR' .AND. (IMP_PHYSICS == 8 .or. IMP_PHYSICS == 28)) THEN DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -2963,7 +2963,7 @@ SUBROUTINE MDLFLD ENDDO ELSE DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = 0.0 DO L=1,NINT(LMH(I,J)) GRID1(I,J) = GRID1(I,J) + 0.00344 * & @@ -2979,7 +2979,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2996,7 +2996,7 @@ SUBROUTINE MDLFLD !--- Needed values at 1st level above ground (Jin, '01; Ferrier, Feb '02) ! DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -3075,7 +3075,7 @@ SUBROUTINE MDLFLD ! DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(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) @@ -3096,7 +3096,7 @@ SUBROUTINE MDLFLD IF (IGET(410)>0) THEN CALL CALVIS_GSD(CZEN,VIS) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=VIS(I,J) END DO END DO @@ -3119,7 +3119,7 @@ SUBROUTINE MDLFLD GRID1 = -20.0 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = REF1KM_10CM(I,J) END DO END DO @@ -3127,7 +3127,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = refl1km(I,J) END DO END DO @@ -3153,7 +3153,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=isx,iex + DO I=ista,iend GRID1(I,J) = REF4KM_10CM(I,J) END DO END DO @@ -3161,7 +3161,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = refl4km(I,J) END DO END DO @@ -3180,7 +3180,7 @@ SUBROUTINE MDLFLD IF (IGET(912)>0) THEN Zm10c=spval DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend ! dong handle missing value if (slp(i,j) < spval) then Zm10c(I,J)=ZMID(I,J,NINT(LMH(I,J))) @@ -3204,7 +3204,7 @@ SUBROUTINE MDLFLD IF(IMP_PHYSICS==8 .or. IMP_PHYSICS==28) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=spval ! dong handle missing value if (slp(i,j) < spval) then @@ -3215,7 +3215,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=spval ! dong handle missing value if (slp(i,j) < spval) then @@ -3248,7 +3248,7 @@ SUBROUTINE MDLFLD IF (IGET(147)>0) THEN ! DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EL0(I,J) ENDDO ENDDO @@ -3268,7 +3268,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,l) DO L=1,LM DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EL(I,J,L) = D00 ENDDO ENDDO @@ -3279,7 +3279,7 @@ SUBROUTINE MDLFLD ELSE IF(MODELNAME == 'NMM')THEN DO L=1,LM DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EL(I,J,L)=EL_PBL(I,J,L) !NOW EL COMES OUT OF WRF NMM ENDDO ENDDO @@ -3302,7 +3302,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EL(I,J,LL) ENDDO ENDDO @@ -3313,7 +3313,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3329,7 +3329,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RICHNO(I,J,LL) ENDDO ENDDO @@ -3340,7 +3340,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3373,7 +3373,7 @@ SUBROUTINE MDLFLD IF (IGET(289) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PBLRI(I,J) ! PBLH(I,J) = PBLRI(I,J) ENDDO @@ -3384,7 +3384,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3398,7 +3398,7 @@ SUBROUTINE MDLFLD IF ( (IGET(389) > 0) .OR. (IGET(454) > 0) ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID3(I,J) = PBLRI(I,J) + ZINT(I,J,LM+1) END DO END DO @@ -3406,7 +3406,7 @@ SUBROUTINE MDLFLD CALL H2U(EGRID3(1:im,JSTA_2L:JEND_2U),EGRID4) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID1(I,J) = 0.0 EGRID2(I,J) = 0.0 END DO @@ -3417,7 +3417,7 @@ SUBROUTINE MDLFLD CALL H2U(PINT(1:IM,JSTA_2L:JEND_2U,L), EGRID7) HCOUNT=0 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend if (EGRID5(I,J) <= EGRID4(I,J)) then ! if (I == 50 .and. J == 50) then @@ -3436,7 +3436,7 @@ SUBROUTINE MDLFLD ENDDO vert_loopu !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(EGRID2(I,J) > 0.)THEN GRID1(I,J) = EGRID1(I,J)/EGRID2(I,J) ELSE @@ -3448,7 +3448,7 @@ SUBROUTINE MDLFLD CALL H2V(EGRID3(1:im,JSTA_2L:JEND_2U),EGRID4) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID1(i,j) = 0. EGRID2(i,j) = 0. EGRID5(i,j) = 0. @@ -3462,7 +3462,7 @@ SUBROUTINE MDLFLD CALL H2V(PINT(1:IM,JSTA_2L:JEND_2U,L), EGRID7) HCOUNT=0 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend if (EGRID5(I,J) <= EGRID4(I,J)) then HCOUNT=HCOUNT+1 DP = EGRID6(I,J) - EGRID7(I,J) @@ -3477,7 +3477,7 @@ SUBROUTINE MDLFLD ENDDO vert_loopv !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(EGRID2(I,J) > 0.)THEN GRID2(I,J) = EGRID1(I,J)/EGRID2(I,J) ELSE @@ -3491,7 +3491,7 @@ SUBROUTINE MDLFLD CALL V2H(GRID2(1,JSTA_2L),EGRID2) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend ! EGRID1 is transport wind speed ! prevent floating overflow if either component is undefined @@ -3516,7 +3516,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3525,7 +3525,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -3543,7 +3543,7 @@ SUBROUTINE MDLFLD ! write(0,*) 'IM is: ', IM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF (PBLRI(I,J) /= SPVAL .and. EGRID3(I,J)/=SPVAL) then GRID1(I,J) = EGRID3(I,J)*PBLRI(I,J) @@ -3566,7 +3566,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3608,7 +3608,7 @@ SUBROUTINE MDLFLD ENDIF DO J=JSTA,JEND - DO I=isx,iex + 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) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend ! if(GUST(I,J) > 200. .and. gust(i,j)0) THEN - allocate(PBLREGIME(isx:iex,jsta_2l:jend_2u)) + allocate(PBLREGIME(ista:iend,jsta_2l:jend_2u)) CALL CALPBLREGIME(PBLREGIME) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PBLREGIME(I,J) ENDDO ENDDO @@ -3681,7 +3681,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3693,7 +3693,7 @@ SUBROUTINE MDLFLD ! IF(IGET(400)>0)THEN DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -3724,7 +3724,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3760,7 +3760,7 @@ SUBROUTINE MDLFLD IF (LVLS(L,IGET(470))>0) THEN LL=LM-L+1 DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=gtg(i,j,LL) ENDDO ENDDO @@ -3771,7 +3771,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3779,7 +3779,7 @@ SUBROUTINE MDLFLD DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=catedr(i,j,LL) ENDDO ENDDO @@ -3790,14 +3790,14 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo endif DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=mwt(i,j,LL) ENDDO ENDDO @@ -3808,7 +3808,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3832,7 +3832,7 @@ SUBROUTINE MDLFLD icing_gfip = spval icing_gfis = spval DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -3866,12 +3866,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=isx,iex +! 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,GRIDisx,iex,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 21e159f6c..ee8bfdf6f 100644 --- a/sorc/ncep_post.fd/MISCLN.f +++ b/sorc/ncep_post.fd/MISCLN.f @@ -89,7 +89,7 @@ SUBROUTINE MISCLN rhmin, rgamog, tfrz, small use ctlblk_mod, only: grib, cfld, fld_info, datapd, im, jsta, jend, jm, & nbnd, nbin_du, lm, htfd, spval, pthresh, nfd, petabnd, me,& - jsta_2l, jend_2u, MODELNAME,isx,iex + jsta_2l, jend_2u, MODELNAME,ista,iend use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml use grib2_module, only: pset use upp_physics, only: FPVSNEW, CALRH_PW, CALCAPE, CALCAPE2 @@ -109,13 +109,13 @@ SUBROUTINE MISCLN ! DECLARE VARIABLES. ! LOGICAL NORTH, FIELD1,FIELD2 - LOGICAL, dimension(isx:iex,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(isx:iex,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 real, dimension(:,:,:),allocatable :: OMGBND, PWTBND, QCNVBND, & @@ -155,10 +155,10 @@ SUBROUTINE MISCLN !**************************************************************************** ! START MISCLN HERE. ! - allocate(USHR1(isx:iex,jsta_2l:jend_2u),VSHR1(isx:iex,jsta_2l:jend_2u), & - USHR6(isx:iex,jsta_2l:jend_2u),VSHR6(isx:iex,jsta_2l:jend_2u)) - allocate(UST(isx:iex,jsta_2l:jend_2u),VST(isx:iex,jsta_2l:jend_2u), & - HELI(isx:iex,jsta_2l:jend_2u,2)) + allocate(USHR1(ista:iend,jsta_2l:jend_2u),VSHR1(ista:iend,jsta_2l:jend_2u), & + USHR6(ista:iend,jsta_2l:jend_2u),VSHR6(ista:iend,jsta_2l:jend_2u)) + allocate(UST(ista:iend,jsta_2l:jend_2u),VST(ista:iend,jsta_2l:jend_2u), & + HELI(ista:iend,jsta_2l:jend_2u,2)) ! ! HELICITY AND STORM MOTION. iget1 = IGET(162) @@ -175,7 +175,7 @@ SUBROUTINE MISCLN IF (iget2 > 0) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = HELI(I,J,1) ENDDO ENDDO @@ -186,7 +186,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -196,7 +196,7 @@ SUBROUTINE MISCLN IF (iget3 > 0) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = HELI(I,J,2) ENDDO ENDDO @@ -207,7 +207,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -217,7 +217,7 @@ SUBROUTINE MISCLN IF (IGET(163) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = UST(I,J) ENDDO ENDDO @@ -227,7 +227,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -236,7 +236,7 @@ SUBROUTINE MISCLN IF (IGET(164) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = VST(I,J) ENDDO ENDDO @@ -246,7 +246,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -264,7 +264,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -283,7 +283,7 @@ SUBROUTINE MISCLN IF(IGET(430) > 0) THEN !$omp parallel do private(i,j,jj) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = USHR1(I,J) ENDDO ENDDO @@ -293,7 +293,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -302,7 +302,7 @@ SUBROUTINE MISCLN IF(IGET(431) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = VSHR1(I,J) ENDDO ENDDO @@ -312,7 +312,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -321,7 +321,7 @@ SUBROUTINE MISCLN IF(IGET(432) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = USHR6(I,J) ENDDO ENDDO @@ -331,7 +331,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -340,7 +340,7 @@ SUBROUTINE MISCLN IF(IGET(433) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = VSHR6(I,J) ENDDO ENDDO @@ -350,7 +350,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -377,7 +377,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=isx,iex + DO I=ista,iend if(PMID(I,J,1) 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = P1D(I,J) ENDDO ENDDO @@ -414,7 +414,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -431,7 +431,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -442,7 +442,7 @@ SUBROUTINE MISCLN IF (IGET(177) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = Z1D(I,J) ENDDO ENDDO @@ -452,7 +452,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -463,7 +463,7 @@ SUBROUTINE MISCLN IF (IGET(055) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = T1D(I,J) ENDDO ENDDO @@ -473,7 +473,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -489,7 +489,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -500,7 +500,7 @@ SUBROUTINE MISCLN IF ((IGET(056) > 0).OR.(IGET(057) > 0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=U1D(I,J) GRID2(I,J)=V1D(I,J) ENDDO @@ -512,7 +512,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -523,7 +523,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -535,7 +535,7 @@ SUBROUTINE MISCLN IF (IGET(058) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = SHR1D(I,J) ENDDO ENDDO @@ -545,7 +545,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -564,7 +564,7 @@ SUBROUTINE MISCLN MAXWU(IM,jsta:jend), MAXWV(IM,jsta:jend),MAXWT(IM,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend MAXWP(I,J)=SPVAL MAXWZ(I,J)=SPVAL MAXWU(I,J)=SPVAL @@ -576,7 +576,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=isx,iex + 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. & @@ -599,7 +599,7 @@ SUBROUTINE MISCLN IF (IGET(173) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = MAXWP(I,J) ENDDO ENDDO @@ -609,7 +609,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -625,7 +625,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -635,7 +635,7 @@ SUBROUTINE MISCLN IF (IGET(174) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = MAXWZ(I,J) ENDDO ENDDO @@ -645,7 +645,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -656,7 +656,7 @@ SUBROUTINE MISCLN IF ((IGET(175) > 0).OR.(IGET(176) > 0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = MAXWU(I,J) GRID2(I,J) = MAXWV(I,J) ENDDO @@ -667,7 +667,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -676,7 +676,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -686,7 +686,7 @@ SUBROUTINE MISCLN IF (IGET(314) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=MAXWT(I,J) ENDDO ENDDO @@ -696,7 +696,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -803,7 +803,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = T7D(I,J,IFD) ENDDO ENDDO @@ -815,7 +815,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -829,7 +829,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -842,7 +842,7 @@ SUBROUTINE MISCLN IF (IGET(911)>0) THEN IF (LVLS(IFD,IGET(911))>0) THEN DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend if ( T7D(I,J,IFD) > 600 ) then GRID1(I,J)=SPVAL else @@ -880,7 +880,7 @@ SUBROUTINE MISCLN IF (work1 > 0 .or. work2 > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = Q7D(I,J,IFD) ENDDO ENDDO @@ -892,7 +892,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -906,7 +906,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -932,7 +932,7 @@ SUBROUTINE MISCLN IF (work1 > 0 .or. work2 > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = P7D(I,J,IFD) ENDDO ENDDO @@ -944,7 +944,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -958,7 +958,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -984,7 +984,7 @@ SUBROUTINE MISCLN IF (work1 > 0 .or. work2 > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = ICINGFD(I,J,IFD) ENDDO ENDDO @@ -996,7 +996,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1010,7 +1010,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1025,7 +1025,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(601))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=AERFD(I,J,IFD,1) ENDDO ENDDO @@ -1037,7 +1037,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1050,7 +1050,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(602))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=AERFD(I,J,IFD,2) ENDDO ENDDO @@ -1062,7 +1062,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1075,7 +1075,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(603))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=AERFD(I,J,IFD,3) ENDDO ENDDO @@ -1087,7 +1087,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1100,7 +1100,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(604))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=AERFD(I,J,IFD,4) ENDDO ENDDO @@ -1112,7 +1112,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1125,7 +1125,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(605))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=AERFD(I,J,IFD,5) ENDDO ENDDO @@ -1137,7 +1137,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1152,7 +1152,7 @@ SUBROUTINE MISCLN IF ((IGET(060)>0).OR.(IGET(061)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=U7D(I,J,IFD) GRID2(I,J)=V6D(I,J,IFD) ENDDO @@ -1166,7 +1166,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1182,7 +1182,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1195,7 +1195,7 @@ SUBROUTINE MISCLN IF ((IGET(576)>0).OR.(IGET(577)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = U7D(I,J,IFD) GRID2(I,J) = V6D(I,J,IFD) ENDDO @@ -1209,7 +1209,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1225,7 +1225,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1261,7 +1261,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(467))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=GTGFD(I,J,IFD) ENDDO ENDDO @@ -1272,7 +1272,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1298,7 +1298,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(468))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=CATFD(I,J,IFD) ENDDO ENDDO @@ -1309,7 +1309,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1335,7 +1335,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(469))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=MWTFD(I,J,IFD) ENDDO ENDDO @@ -1346,7 +1346,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1374,7 +1374,7 @@ SUBROUTINE MISCLN IF (IGET(062)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1385,7 +1385,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1396,7 +1396,7 @@ SUBROUTINE MISCLN IF (IGET(063)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RH1D(I,J) ENDDO ENDDO @@ -1408,7 +1408,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1419,7 +1419,7 @@ SUBROUTINE MISCLN IF (IGET(753)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = P1D(I,J) ENDDO ENDDO @@ -1429,7 +1429,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1445,7 +1445,7 @@ SUBROUTINE MISCLN IF (IGET(165)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1456,7 +1456,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1467,7 +1467,7 @@ SUBROUTINE MISCLN IF (IGET(350)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=RH1D(I,J)*100. ENDDO ENDDO @@ -1478,7 +1478,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1489,7 +1489,7 @@ SUBROUTINE MISCLN IF (IGET(756)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = P1D(I,J) ENDDO ENDDO @@ -1499,7 +1499,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1517,7 +1517,7 @@ SUBROUTINE MISCLN IF (IGET(776)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1528,7 +1528,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1539,7 +1539,7 @@ SUBROUTINE MISCLN IF (IGET(777)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=RH1D(I,J)*100. ENDDO ENDDO @@ -1550,7 +1550,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1561,7 +1561,7 @@ SUBROUTINE MISCLN IF (IGET(778)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=P1D(I,J) ENDDO ENDDO @@ -1571,7 +1571,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1589,7 +1589,7 @@ SUBROUTINE MISCLN IF (IGET(779)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1600,7 +1600,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1611,7 +1611,7 @@ SUBROUTINE MISCLN IF (IGET(780)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=RH1D(I,J)*100. ENDDO ENDDO @@ -1622,7 +1622,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1633,7 +1633,7 @@ SUBROUTINE MISCLN IF (IGET(781)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=P1D(I,J) ENDDO ENDDO @@ -1643,7 +1643,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1685,7 +1685,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID2(i,j) = SPVAL ENDDO ENDDO @@ -1699,7 +1699,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(067))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PBND(I,J,LBND) ENDDO ENDDO @@ -1710,7 +1710,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1723,7 +1723,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(068))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=TBND(I,J,LBND) ENDDO ENDDO @@ -1734,7 +1734,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1753,7 +1753,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1766,7 +1766,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(072))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=RHBND(I,J,LBND) ENDDO ENDDO @@ -1779,7 +1779,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1799,7 +1799,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1812,7 +1812,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(071))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=QBND(I,J,LBND) ENDDO ENDDO @@ -1824,7 +1824,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1837,7 +1837,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(088))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = QCNVBND(I,J,LBND) ENDDO ENDDO @@ -1848,7 +1848,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1871,7 +1871,7 @@ SUBROUTINE MISCLN IF(FIELD1.OR.FIELD2)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = UBND(I,J,LBND) GRID2(I,J) = VBND(I,J,LBND) ENDDO @@ -1886,7 +1886,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1902,7 +1902,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1916,7 +1916,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(090))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = OMGBND(I,J,LBND) ENDDO ENDDO @@ -1927,7 +1927,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1940,7 +1940,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(089))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PWTBND(I,J,LBND) ENDDO ENDDO @@ -1952,7 +1952,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1973,7 +1973,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1983,7 +1983,7 @@ SUBROUTINE MISCLN IF(IGET(031)>0 .or. IGET(573)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID2(I,J) = MIN(EGRID2(I,J),GRID1(I,J)) END DO END DO @@ -1998,7 +1998,7 @@ SUBROUTINE MISCLN ! IF (IGET(031)>0 .OR. IGET(573)>0 ) THEN ! DO J=JSTA,JEND -! DO I=isx,iex +! DO I=ista,iend ! EGRID1(I,J) = H99999 ! EGRID2(I,J) = H99999 ! ENDDO @@ -2008,14 +2008,14 @@ SUBROUTINE MISCLN ! CALL OTLFT(PBND(1,1,LBND),TBND(1,1,LBND), & ! QBND(1,1,LBND),EGRID2) ! DO J=JSTA,JEND -! DO I=isx,iex +! DO I=ista,iend ! EGRID1(I,J)=AMIN1(EGRID1(I,J),EGRID2(I,J)) ! ENDDO ! ENDDO ! 50 CONTINUE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=EGRID2(I,J) ENDDO ENDDO @@ -2036,7 +2036,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2074,7 +2074,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 ENDDO @@ -2085,7 +2085,7 @@ SUBROUTINE MISCLN QBND(1,jsta,LBND),EGRID1) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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) @@ -2106,7 +2106,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -2118,7 +2118,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2130,7 +2130,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -2139,7 +2139,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -2151,7 +2151,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2164,7 +2164,7 @@ SUBROUTINE MISCLN IF(IGET(221) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PBLH(I,J) ENDDO ENDDO @@ -2174,7 +2174,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2189,7 +2189,7 @@ SUBROUTINE MISCLN IF (IGET(109)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID2(I,J) ENDDO ENDDO @@ -2199,7 +2199,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2208,7 +2208,7 @@ SUBROUTINE MISCLN IF (IGET(110)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -2218,7 +2218,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2242,7 +2242,7 @@ SUBROUTINE MISCLN IF (IGET(097)>0.OR.IGET(098)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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 @@ -2252,7 +2252,7 @@ SUBROUTINE MISCLN !!$omp parallel do private(fac1,fac2,pkl1,pku1,t78483,t89671) DO L=2,LM DO J=JSTA,JEND - DO I=isx,iex + 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= ', & @@ -2276,7 +2276,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=isx,iex + 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)) @@ -2345,7 +2345,7 @@ SUBROUTINE MISCLN IF (IGET(097) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = T89671(I,J) ! IF(T89671(I,J)>350.)PRINT*,'LARGE T89671 ', & ! I,J,T89671(I,J) @@ -2358,7 +2358,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2369,7 +2369,7 @@ SUBROUTINE MISCLN IF (IGET(098)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = T78483(I,J) ENDDO ENDDO @@ -2380,7 +2380,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2403,7 +2403,7 @@ SUBROUTINE MISCLN IF (IGET(091)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PBND(I,J,1) ENDDO ENDDO @@ -2413,7 +2413,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2424,7 +2424,7 @@ SUBROUTINE MISCLN IF (IGET(092)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = TBND(I,J,1) ENDDO ENDDO @@ -2435,7 +2435,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2446,7 +2446,7 @@ SUBROUTINE MISCLN IF (IGET(093)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = QBND(I,J,1) ENDDO ENDDO @@ -2458,7 +2458,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2469,7 +2469,7 @@ SUBROUTINE MISCLN IF (IGET(094)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RHBND(I,J,1) ENDDO ENDDO @@ -2482,7 +2482,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2493,7 +2493,7 @@ SUBROUTINE MISCLN IF ((IGET(095)>0).OR.(IGET(096)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = UBND(I,J,1) GRID2(I,J) = VBND(I,J,1) ENDDO @@ -2506,7 +2506,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2520,7 +2520,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2555,7 +2555,7 @@ SUBROUTINE MISCLN IF (IGET(066)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RH3310(I,J) ENDDO ENDDO @@ -2568,7 +2568,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2581,7 +2581,7 @@ SUBROUTINE MISCLN IF (IGET(081)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RH6610(I,J) ENDDO ENDDO @@ -2594,7 +2594,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2605,7 +2605,7 @@ SUBROUTINE MISCLN IF (IGET(082)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RH3366(I,J) ENDDO ENDDO @@ -2618,7 +2618,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2629,7 +2629,7 @@ SUBROUTINE MISCLN IF (IGET(104)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = PW3310(I,J) ENDDO ENDDO @@ -2641,7 +2641,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2665,7 +2665,7 @@ SUBROUTINE MISCLN IF (IGET(099)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RH4710(I,J) ENDDO ENDDO @@ -2678,7 +2678,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2689,7 +2689,7 @@ SUBROUTINE MISCLN IF (IGET(100)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RH4796(I,J) ENDDO ENDDO @@ -2702,7 +2702,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2713,7 +2713,7 @@ SUBROUTINE MISCLN IF (IGET(101)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RH1847(I,J) ENDDO ENDDO @@ -2726,7 +2726,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2737,7 +2737,7 @@ SUBROUTINE MISCLN IF (IGET(102)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RH8498(I,J) ENDDO ENDDO @@ -2750,7 +2750,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2762,7 +2762,7 @@ SUBROUTINE MISCLN ! CONVERT TO DIVERGENCE FOR GRIB !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = -1.0*QM8510(I,J) ENDDO ENDDO @@ -2773,7 +2773,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2794,7 +2794,7 @@ SUBROUTINE MISCLN IF (IGET(318)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RH4410(I,J)*100. ENDDO ENDDO @@ -2806,7 +2806,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2817,7 +2817,7 @@ SUBROUTINE MISCLN IF (IGET(319)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = RH7294(I,J)*100. ENDDO ENDDO @@ -2829,7 +2829,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2840,7 +2840,7 @@ SUBROUTINE MISCLN IF (IGET(320)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J)=RH4472(I,J)*100. ENDDO ENDDO @@ -2852,7 +2852,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2867,7 +2867,7 @@ SUBROUTINE MISCLN (IGET(325)>0).OR.(IGET(326)>0) ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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)) @@ -2887,7 +2887,7 @@ SUBROUTINE MISCLN IF (IGET(321)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = T(I,J,LM)+(T(I,J,LM-1)-T(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -2899,7 +2899,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2911,7 +2911,7 @@ SUBROUTINE MISCLN IF (IGET(322)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID2(I,J) = T(I,J,LM)+(T(I,J,LM-1)-T(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -2924,7 +2924,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2934,7 +2934,7 @@ SUBROUTINE MISCLN IF (IGET(323)>0) THEN !$omp parallel do private(i,j,es1,qs1,rh1,es2,qs2,rh2) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend ES1 = min(PMID(I,J,LM),FPVSNEW(T(I,J,LM))) QS1 = CON_EPS*ES1/(PMID(I,J,LM)+CON_EPSM1*ES1) RH1 = Q(I,J,LM)/QS1 @@ -2952,7 +2952,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2962,7 +2962,7 @@ SUBROUTINE MISCLN IF (IGET(324)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = UH(I,J,LM)+(UH(I,J,LM-1)-UH(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -2974,7 +2974,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2984,7 +2984,7 @@ SUBROUTINE MISCLN IF (IGET(325)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = VH(I,J,LM)+(VH(I,J,LM-1)-VH(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -2996,7 +2996,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3006,7 +3006,7 @@ SUBROUTINE MISCLN IF (IGET(326)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = OMGA(I,J,LM)+(OMGA(I,J,LM-1)-OMGA(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -3018,7 +3018,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3050,13 +3050,13 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 ! ENDDO ! ENDDO ! DO J=JSTA,JEND -! DO I=isx,iex +! DO I=ista,iend LB2(I,J) = (LVLBND(I,J,1) + LVLBND(I,J,2) + & LVLBND(I,J,3))/3 P1D(I,J) = (PBND(I,J,1) + PBND(I,J,2) + PBND(I,J,3))/3 @@ -3074,7 +3074,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -3087,7 +3087,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3098,7 +3098,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -3107,7 +3107,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -3119,7 +3119,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3135,7 +3135,7 @@ SUBROUTINE MISCLN ! CALL CALLCL(P1D,T1D,Q1D,EGRID1,EGRID2) ! IF (IGET(109)>0) THEN ! DO J=JSTA,JEND -! DO I=isx,iex +! DO I=ista,iend ! GRID1(I,J)=EGRID2(I,J) ! ENDDO ! ENDDO @@ -3143,12 +3143,12 @@ SUBROUTINE MISCLN ! ID(1:25) = 0 ! ! CALL GRIBIT(IGET(109),1, -! X GRIDisx,iex,JM) +! X GRIDista,iend,JM) ! ENDIF ! ! IF (IGET(110)>0) THEN ! DO J=JSTA,JEND -! DO I=isx,iex +! DO I=ista,iend ! GRID1(I,J)=EGRID1(I,J) ! ENDDO ! ENDDO @@ -3156,7 +3156,7 @@ SUBROUTINE MISCLN ! ID(1:25) = 0 ! ! CALL GRIBIT(IGET(110),1, -! X GRIDisx,iex,JM) +! X GRIDista,iend,JM) ! ENDIF ! ENDIF ! @@ -3185,7 +3185,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 ENDDO @@ -3200,7 +3200,7 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -3212,7 +3212,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3225,14 +3225,14 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + 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=isx,iex + DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -3243,7 +3243,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3255,7 +3255,7 @@ SUBROUTINE MISCLN IF (IGET(443)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID4(I,J) ENDDO ENDDO @@ -3266,7 +3266,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3278,7 +3278,7 @@ SUBROUTINE MISCLN IF (IGET(246)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -3292,7 +3292,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3303,7 +3303,7 @@ SUBROUTINE MISCLN IF (IGET(444)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF (CPRATE(I,J) > PTHRESH) THEN GRID1(I,J) = EGRID5(I,J) ELSE @@ -3319,7 +3319,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3353,7 +3353,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 EGRID3(I,J) = -H99999 @@ -3365,7 +3365,7 @@ SUBROUTINE MISCLN ! ENDDO ! ENDDO ! DO J=JSTA,JEND -! DO I=isx,iex +! DO I=ista,iend LB2(I,J) = (LVLBND(I,J,1) + LVLBND(I,J,2) + & LVLBND(I,J,3))/3 P1D(I,J) = (PBND(I,J,1) + PBND(I,J,2) + PBND(I,J,3))/3 @@ -3387,7 +3387,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -3399,7 +3399,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3411,7 +3411,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -3420,7 +3420,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -3432,7 +3432,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3444,7 +3444,7 @@ SUBROUTINE MISCLN IF (IGET(952)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -3456,7 +3456,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3485,7 +3485,7 @@ SUBROUTINE MISCLN DEPTH(2) = 1000.0 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend LLOW(I,J) = INT(EGRID4(I,J)) LUPP(I,J) = INT(EGRID5(I,J)) ENDDO @@ -3497,7 +3497,7 @@ SUBROUTINE MISCLN IF (iget2 > 0) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = HELI(I,J,1) ! GRID1(I,J) = HELI(I,J,2) ENDDO @@ -3509,7 +3509,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3523,7 +3523,7 @@ SUBROUTINE MISCLN IF (IGET(957)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = CANGLE(I,J) ! IF(EGRID1(I,J)<100. .OR. EGRID2(I,J)>-250.) THEN ! GRID1(I,J) = 0. @@ -3537,7 +3537,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3549,7 +3549,7 @@ SUBROUTINE MISCLN IF (IGET(955)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID7(I,J) ENDDO ENDDO @@ -3561,7 +3561,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3573,7 +3573,7 @@ SUBROUTINE MISCLN IF (IGET(956)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend GRID1(I,J) = EGRID8(I,J) ENDDO ENDDO @@ -3585,7 +3585,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3596,7 +3596,7 @@ SUBROUTINE MISCLN ITYPE = 1 ! DO J=JSTA,JEND - ! DO I=isx,iex + ! DO I=ista,iend ! LB2(I,J) = (LVLBND(I,J,1) + LVLBND(I,J,2) + & ! LVLBND(I,J,3))/3 ! P1D(I,J) = (PBND(I,J,1) + PBND(I,J,2) + PBND(I,J,3))/3 @@ -3614,7 +3614,7 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=isx,iex + DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = -EGRID6(I,J) ENDDO ENDDO @@ -3626,7 +3626,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3667,7 +3667,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 2243fc624..583602164 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -13,7 +13,7 @@ !! 02-06-19 MIKE BALDWIN - WRF VERSION !! 11-12-16 SARAH LU - MODIFIED TO INITIALIZE AEROSOL FIELDS !! 12-01-07 SARAH LU - MODIFIED TO INITIALIZE AIR DENSITY/LAYER THICKNESS -!! 3/28/2021 George Vandenberghe. Added isx and iex variables to +!! 3/28/2021 George Vandenberghe. Added ista and iend variables to !! determine lower and upper bounds for a 2D decomposition !! !! USAGE: CALL MPI_FIRST @@ -88,7 +88,7 @@ SUBROUTINE MPI_FIRST() jend_m, jend_m2, iup, idn, icnt, im, idsp, jsta_2l, jend_2u, & jvend_2u, lm, lp1, jsta_2l, jend_2u, nsoil, nbin_du, nbin_ss, & nbin_bc, nbin_oc, nbin_su, & - isx,iex + ista,iend ! ! use params_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -124,7 +124,7 @@ SUBROUTINE MPI_FIRST() ! para_range2) ! !gwv call para_range(1,jm,num_procs,me,jsta,jend) - call para_range2(1,jm,1,im,num_procs,me,jsta,jend,isx,iex) + call para_range2(1,jm,1,im,num_procs,me,jsta,jend,ista,iend) jsta_m = jsta jsta_m2 = jsta jend_m = jend @@ -157,7 +157,7 @@ SUBROUTINE MPI_FIRST() ! counts, disps for gatherv and scatterv ! do i = 0, num_procs - 1 - call para_range2(1,jm,1,im,num_procs,i,jsx,jex,isx,iex) + call para_range2(1,jm,1,im,num_procs,i,jsx,jex,ista,iend) !gwv delete after 2D support is validated call para_range(1,jm,num_procs,i,jsx,jex) icnt(i) = (jex-jsx+1)*im idsp(i) = (jsx-1)*im @@ -183,6 +183,6 @@ SUBROUTINE MPI_FIRST() ! print *, 'GWVX me, jsta_2l, jend_2u = ',me,jsta_2l, jend_2u, & 'jvend_2u=',jvend_2u,'im=',im,'jm=',jm,'lm=',lm, & - 'lp1=',lp1,' isx and iex= ',isx,iex + 'lp1=',lp1,' ista and iend= ',ista,iend end diff --git a/sorc/ncep_post.fd/PARA_RANGE.f b/sorc/ncep_post.fd/PARA_RANGE.f index 9aea0a070..f1af1d59d 100644 --- a/sorc/ncep_post.fd/PARA_RANGE.f +++ b/sorc/ncep_post.fd/PARA_RANGE.f @@ -46,21 +46,21 @@ SUBROUTINE PARA_RANGE (N1,N2,NPROCS,IRANK,ISTA,IEND) if ( iwork2 > irank ) iend = iend + 1 return end - SUBROUTINE PARA_RANGE2 (N1,N2,i1,i2,NPROCS,IRANK,ISTA,IEND,isx,iex) + SUBROUTINE PARA_RANGE2 (N1,N2,i1,i2,NPROCS,IRANK,ISTAJ,IENDJ,isx,iex) implicit none integer,intent(in) :: n1,n2,nprocs,irank,i1,i2 - integer,intent(out) :: ista,iend,isx,iex + integer,intent(out) :: istaj,iendj,isx,iex integer iwork1, iwork2 iwork1 = ( n2 - n1 + 1 ) / nprocs iwork2 = mod ( n2 - n1 + 1, nprocs ) - ista = irank * iwork1 + n1 + min ( irank, iwork2 ) - iend = ista + iwork1 - 1 - if ( iwork2 > irank ) iend = iend + 1 + istaj = irank * iwork1 + n1 + min ( irank, iwork2 ) + iendj = istaj + iwork1 - 1 + if ( iwork2 > irank ) iendj = iendj + 1 isx=i1 iex=i2 - print 101,' GWVX para_range2 irank,iwork1,iwork2,ista,iend,i1,i2,isx,iex',irank,iwork1,iwork2,ista,iend,i1,i2,isx,iex + print 101,' GWVX para_range2 irank,iwork1,iwork2,istaj,iendj,i1,i2,isx,iex',irank,iwork1,iwork2,istaj,iendj,i1,i2,isx,iex 101 format( a70,11i8) return end diff --git a/sorc/ncep_post.fd/SURFCE.f b/sorc/ncep_post.fd/SURFCE.f index d53d25b50..1225d3c9f 100644 --- a/sorc/ncep_post.fd/SURFCE.f +++ b/sorc/ncep_post.fd/SURFCE.f @@ -101,7 +101,7 @@ SUBROUTINE SURFCE modelname, tmaxmin, pthresh, dtq2, dt, nphs, & ifhr, prec_acc_dt, sdat, ihrst, jsta_2l, jend_2u,& lp1, imp_physics, me, asrfc, tsrfc, pt, pdtop, & - mpi_comm_comp, im, jm, prec_acc_dt1,isx,iex + mpi_comm_comp, im, jm, prec_acc_dt1,ista,iend use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml use upp_physics, only: fpvsnew, CALRH !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -125,7 +125,7 @@ SUBROUTINE SURFCE ! DECLARE VARIABLES. ! !gwvx integer, dimension(im,jsta:jend) :: nroots, iwx1 - integer, dimension(isx:iex,jsta:jend) :: nroots, iwx1 + integer, dimension(ista:iend,jsta:jend) :: nroots, iwx1 real, allocatable, dimension(:,:) :: zsfc, psfc, tsfc, qsfc, & rhsfc, thsfc, dwpsfc, p1d, & t1d, q1d, zwet, & @@ -133,10 +133,10 @@ SUBROUTINE SURFCE domip, domzr, rsmin, smcref,& rcq, rct, rcsoil, gc, rcs - real, dimension(isx:iex,jsta:jend) :: evp - real, dimension(isx:iex,jsta_2l:jend_2u) :: egrid1, egrid2 + real, dimension(ista:iend,jsta:jend) :: evp + real, dimension(ista:iend,jsta_2l:jend_2u) :: egrid1, egrid2 real, dimension(im,jm) :: grid1, grid2 - real, dimension(isx:iex,jsta_2l:jend_2u) :: iceg + real, dimension(ista:iend,jsta_2l:jend_2u) :: iceg ! , ua, va real, allocatable, dimension(:,:,:) :: sleet, rain, freezr, snow ! real, dimension(im,jm,nalg) :: sleet, rain, freezr, snow @@ -170,11 +170,11 @@ SUBROUTINE SURFCE (IGET(154)>0).OR. & (IGET(034)>0).OR.(IGET(076)>0) ) THEN ! - allocate(zsfc(isx:iex,jsta:jend), psfc(isx:iex,jsta:jend), tsfc(isx:iex,jsta:jend)& - ,rhsfc(isx:iex,jsta:jend), thsfc(isx:iex,jsta:jend), qsfc(isx:iex,jsta:jend)) + allocate(zsfc(ista:iend,jsta:jend), psfc(ista:iend,jsta:jend), tsfc(ista:iend,jsta:jend)& + ,rhsfc(ista:iend,jsta:jend), thsfc(ista:iend,jsta:jend), qsfc(ista:iend,jsta:jend)) !$omp parallel do private(i,j,tsfck,qsat) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend ! ! SCALE ARRAY FIS BY GI TO GET SURFACE HEIGHT. ! ZSFC(I,J)=FIS(I,J)*GI @@ -243,7 +243,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = PSFC(i,jj) enddo enddo @@ -259,7 +259,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = ZSFC(i,jj) enddo enddo @@ -276,7 +276,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = TSFC(i,jj) enddo enddo @@ -292,7 +292,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = THSFC(i,jj) enddo enddo @@ -309,7 +309,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = QSFC(i,jj) enddo enddo @@ -327,7 +327,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = DWPSFC(i,jj) enddo enddo @@ -344,7 +344,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = RHSFC(i,jj) enddo enddo @@ -364,7 +364,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = QVG(i,jj) enddo enddo @@ -380,7 +380,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = QV2M(i,jj) enddo enddo @@ -395,7 +395,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = TSNOW(i,jj) enddo enddo @@ -410,7 +410,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = SNFDEN(i,jj) enddo enddo @@ -448,7 +448,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = SNDEPAC(i,jj) enddo enddo @@ -474,7 +474,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = STC(i,jj,l) enddo enddo @@ -494,7 +494,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = STC(i,jj,l) enddo enddo @@ -515,7 +515,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = SMC(i,jj,l) enddo enddo @@ -533,7 +533,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = SMC(i,jj,l) enddo enddo @@ -552,7 +552,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = SH2O(i,jj,l) enddo enddo @@ -570,7 +570,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = SH2O(i,jj,l) enddo enddo @@ -590,7 +590,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = TG(i,jj) enddo enddo @@ -602,7 +602,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = TG(i,jj) enddo enddo @@ -613,7 +613,7 @@ SUBROUTINE SURFCE IF (IGET(171)>0) THEN !!$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF(SMSTAV(I,J) /= SPVAL)THEN GRID1(I,J) = SMSTAV(I,J)*100. ELSE @@ -627,7 +627,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -638,7 +638,7 @@ SUBROUTINE SURFCE IF (IGET(036)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + 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 @@ -656,7 +656,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -668,7 +668,7 @@ SUBROUTINE SURFCE IF(MODELNAME == 'RAPR') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF(CMC(I,J) /= SPVAL) then GRID1(I,J) = CMC(I,J) else @@ -679,7 +679,7 @@ SUBROUTINE SURFCE else !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF(CMC(I,J) /= SPVAL) then GRID1(I,J) = CMC(I,J)*1000. else @@ -694,7 +694,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -710,7 +710,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = SNO(i,jj) enddo enddo @@ -722,7 +722,7 @@ SUBROUTINE SURFCE ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + 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) @@ -761,7 +761,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -787,7 +787,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = PSFCAVG(i,jj) enddo enddo @@ -816,7 +816,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = T10AVG(i,jj) enddo enddo @@ -827,7 +827,7 @@ SUBROUTINE SURFCE IF ( IGET(244)>0 ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = SNONC(I,J) ENDDO ENDDO @@ -864,7 +864,7 @@ SUBROUTINE SURFCE IF ( IGET(120)>0 ) THEN GRID1=SPVAL DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend ! GRID1(I,J)=PCTSNO(I,J) IF ( SNO(I,J) /= SPVAL ) THEN SNEQV = SNO(I,J) @@ -882,7 +882,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -895,7 +895,7 @@ SUBROUTINE SURFCE ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + 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 @@ -907,7 +907,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -921,7 +921,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = POTEVP(i,jj) enddo enddo @@ -935,7 +935,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = DZICE(i,jj) enddo enddo @@ -961,7 +961,7 @@ SUBROUTINE SURFCE allocate(smcdry(im,jsta:jend), & smcmax(im,jsta:jend)) DO J=JSTA,JEND - do i=isx,iex + 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 @@ -990,7 +990,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = ECAN(i,jj) enddo enddo @@ -1004,7 +1004,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = EDIR(i,jj) enddo enddo @@ -1034,7 +1034,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = SMCDRY(i,jj) enddo enddo @@ -1048,7 +1048,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = SMCMAX(i,jj) enddo enddo @@ -1072,7 +1072,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = acond(i,jj) enddo enddo @@ -1110,7 +1110,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = avgECAN(i,jj) enddo enddo @@ -1148,7 +1148,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = avgEDIR(i,jj) enddo enddo @@ -1238,7 +1238,7 @@ SUBROUTINE SURFCE !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=isx,iex + 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) @@ -1255,7 +1255,7 @@ SUBROUTINE SURFCE IF (IGET(106)>0) THEN ! GRID1=spval DO J=JSTA,JEND - do i=isx,iex + 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 @@ -1277,7 +1277,7 @@ SUBROUTINE SURFCE IF (IGET(546)>0) THEN ! GRID1=spval ! DO J=JSTA,JEND -! do i=isx,iex +! do i=ista,iend ! GRID1(I,J)=TSHLTR(I,J) ! ENDDO ! ENDDO @@ -1291,7 +1291,7 @@ SUBROUTINE SURFCE ! SHELTER LEVEL SPECIFIC HUMIDITY. IF (IGET(112)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = QSHLTR(I,J) ENDDO ENDDO @@ -1306,7 +1306,7 @@ SUBROUTINE SURFCE ! SHELTER MIXING RATIO. IF (IGET(414)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = MRSHLTR(I,J) ENDDO ENDDO @@ -1322,7 +1322,7 @@ SUBROUTINE SURFCE IF ((IGET(113)>0) .OR.(IGET(547)>0).OR.(IGET(548)>0)) THEN DO J=JSTA,JEND - do i=isx,iex + 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 @@ -1347,7 +1347,7 @@ SUBROUTINE SURFCE GRID1=spval if(MODELNAME=='RAPR')THEN DO J=JSTA,JEND - do i=isx,iex + 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) @@ -1355,7 +1355,7 @@ SUBROUTINE SURFCE ENDDO else DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend if(qshltr(i,j)/=spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1372,7 +1372,7 @@ SUBROUTINE SURFCE ! DEWPOINT at level 1 ------ p1d and t1d are undefined !! -- Moorthi IF (IGET(771)>0) THEN DO J=JSTA,JEND - do i=isx,iex + 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 @@ -1381,7 +1381,7 @@ SUBROUTINE SURFCE ! print *,' MAX DEWPOINT at level 1',maxval(egrid1) GRID1=spval DO J=JSTA,JEND - do i=isx,iex + 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 @@ -1397,7 +1397,7 @@ SUBROUTINE SURFCE ! IF ((IGET(547)>0).OR.(IGET(548)>0)) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend ! DEWPOINT DEPRESSION in GRID1 GRID1(i,j)=max(0.,TSHLTR(I,J)*(PSHLTR(I,J)*1.E-5)**CAPA-EGRID1(i,j)) @@ -1436,7 +1436,7 @@ SUBROUTINE SURFCE allocate(q1d(im,jsta:jend)) !$omp parallel do private(i,j,llmh) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF(MODELNAME=='RAPR')THEN LLMH = NINT(LMH(I,J)) ! P1D(I,J)=PINT(I,J,LLMH+1) @@ -1455,7 +1455,7 @@ SUBROUTINE SURFCE if (allocated(q1d)) deallocate(q1d) !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend if(qshltr(i,j) /= spval)then GRID1(I,J) = EGRID1(I,J)*100. else @@ -1471,7 +1471,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1481,7 +1481,7 @@ SUBROUTINE SURFCE IF(IGET(808)>0)THEN !$omp parallel do private(i,j,dum1,dum2,dum3,dum216,dum1s,dum3s) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend DUM1 = (T1D(I,J)-TFRZ)*1.8+32. DUM2 = SQRT(U10H(I,J)**2.0+V10H(I,J)**2.0)/0.44704 DUM3 = EGRID1(I,J) * 100.0 @@ -1518,7 +1518,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1534,7 +1534,7 @@ SUBROUTINE SURFCE ! SHELTER LEVEL PRESSURE. IF (IGET(138)>0) THEN ! DO J=JSTA,JEND -! do i=isx,iex +! do i=ista,iend ! GRID1(I,J)=PSHLTR(I,J) ! ENDDO ! ENDDO @@ -1544,7 +1544,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = PSHLTR(i,jj) enddo enddo @@ -1556,7 +1556,7 @@ SUBROUTINE SURFCE ! SHELTER LEVEL MAX TEMPERATURE. IF (IGET(345)>0) THEN ! DO J=JSTA,JEND -! do i=isx,iex +! do i=ista,iend ! GRID1(I,J)=MAXTSHLTR(I,J) ! ENDDO ! ENDDO @@ -1593,7 +1593,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = MAXTSHLTR(i,jj) enddo enddo @@ -1604,7 +1604,7 @@ SUBROUTINE SURFCE IF (IGET(346)>0) THEN !!$omp parallel do private(i,j) ! DO J=JSTA,JEND -! do i=isx,iex +! do i=ista,iend ! GRID1(I,J) = MINTSHLTR(I,J) ! ENDDO ! ENDDO @@ -1639,7 +1639,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = MINTSHLTR(i,jj) enddo enddo @@ -1649,7 +1649,7 @@ SUBROUTINE SURFCE ! SHELTER LEVEL MAX RH. IF (IGET(347)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=MAXRHSHLTR(I,J)*100. ENDDO ENDDO @@ -1690,7 +1690,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1700,7 +1700,7 @@ SUBROUTINE SURFCE ! SHELTER LEVEL MIN RH. IF (IGET(348)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=MINRHSHLTR(I,J)*100. ENDDO ENDDO @@ -1739,7 +1739,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1779,7 +1779,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = maxqshltr(i,jj) enddo enddo @@ -1818,7 +1818,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = minqshltr(i,jj) enddo enddo @@ -1829,7 +1829,7 @@ SUBROUTINE SURFCE ! IF (IGET(739)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = (1./RD)*(PMID(I,J,LM)/T(I,J,LM))*SMOKE(I,J,LM,1) ENDDO ENDDO @@ -1849,7 +1849,7 @@ SUBROUTINE SURFCE IF ((IGET(064)>0).OR.(IGET(065)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = U10(I,J) GRID2(I,J) = V10(I,J) ENDDO @@ -1860,7 +1860,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1869,7 +1869,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1879,7 +1879,7 @@ SUBROUTINE SURFCE IF (IGET(730)>0) THEN IFINCR = 5 DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=SPDUV10MEAN(I,J) ENDDO ENDDO @@ -1903,7 +1903,7 @@ SUBROUTINE SURFCE IF (IGET(731)>0) THEN IFINCR = 5 DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=U10MEAN(I,J) ENDDO ENDDO @@ -1925,7 +1925,7 @@ SUBROUTINE SURFCE IF (IGET(732)>0) THEN IFINCR = 5 DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=V10MEAN(I,J) ENDDO ENDDO @@ -1947,7 +1947,7 @@ SUBROUTINE SURFCE IF (IGET(733)>0 )THEN IFINCR = 15 DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = SWRADMEAN(I,J) ENDDO ENDDO @@ -1969,7 +1969,7 @@ SUBROUTINE SURFCE IF (IGET(734)>0 )THEN IFINCR = 15 DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = SWNORMMEAN(I,J) ENDDO ENDDO @@ -1999,7 +1999,7 @@ SUBROUTINE SURFCE ENDIF !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = U10MAX(I,J) GRID2(I,J) = V10MAX(I,J) ENDDO @@ -2012,7 +2012,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2023,7 +2023,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2037,7 +2037,7 @@ SUBROUTINE SURFCE IF (IGET(158)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=TH10(I,J) ENDDO ENDDO @@ -2047,7 +2047,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2059,7 +2059,7 @@ SUBROUTINE SURFCE IF (IGET(505)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=T10M(I,J) ENDDO ENDDO @@ -2069,7 +2069,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2081,7 +2081,7 @@ SUBROUTINE SURFCE IF (IGET(159)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = Q10(I,J) ENDDO ENDDO @@ -2091,7 +2091,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2105,7 +2105,7 @@ SUBROUTINE SURFCE IF (IGET(422)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = WSPD10MAX(I,J) ENDDO ENDDO @@ -2121,7 +2121,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2133,7 +2133,7 @@ SUBROUTINE SURFCE IF (IGET(783)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = WSPD10UMAX(I,J) ENDDO ENDDO @@ -2149,7 +2149,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2161,7 +2161,7 @@ SUBROUTINE SURFCE IF (IGET(784)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = WSPD10VMAX(I,J) ENDDO ENDDO @@ -2177,7 +2177,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2195,7 +2195,7 @@ SUBROUTINE SURFCE CALL CALVESSEL(ICEG(1,jsta)) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = ICEG(I,J) ENDDO ENDDO @@ -2213,7 +2213,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2240,7 +2240,7 @@ SUBROUTINE SURFCE IF (IGET(172)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF (PREC(I,J) <= PTHRESH .OR. SR(I,J)==spval) THEN GRID1(I,J) = -50. ELSE @@ -2254,7 +2254,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2268,7 +2268,7 @@ SUBROUTINE SURFCE ! RDTPHS=1000./(TRDLW*3600.) !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = CPRATE(I,J)*RDTPHS ! GRID1(I,J) = CUPPT(I,J)*RDTPHS ENDDO @@ -2279,7 +2279,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2293,7 +2293,7 @@ SUBROUTINE SURFCE !MEB need to get physics DT !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF(MODELNAME /= 'RSM') THEN GRID1(I,J) = PREC(I,J)*RDTPHS*1000. ELSE !Add by Binbin @@ -2307,7 +2307,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2318,7 +2318,7 @@ SUBROUTINE SURFCE IF (IGET(508)>0) THEN !-- PRATE_MAX in units of mm/h from NMMB history files DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=PRATE_MAX(I,J)*SEC2HR ENDDO ENDDO @@ -2335,7 +2335,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2346,7 +2346,7 @@ SUBROUTINE SURFCE IF (IGET(509)>0) THEN !-- FPRATE_MAX in units of mm/h from NMMB history files DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=FPRATE_MAX(I,J)*SEC2HR ENDDO ENDDO @@ -2363,7 +2363,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2397,7 +2397,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend if(AVGCPRATE(I,J)/=spval) GRID1(I,J) = AVGCPRATE(I,J)*RDTPHS ENDDO ENDDO @@ -2419,7 +2419,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2454,7 +2454,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend if(avgprec(i,j)/=spval) GRID1(I,J) = AVGPREC(I,J)*RDTPHS ENDDO ENDDO @@ -2473,7 +2473,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2505,7 +2505,7 @@ SUBROUTINE SURFCE IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + 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 @@ -2515,7 +2515,7 @@ SUBROUTINE SURFCE ENDDO !! Chuang 3/29/2018: add continuous bucket ! DO J=JSTA,JEND -! do i=isx,iex +! do i=ista,iend ! IF(AVGPREC_CONT(I,J) < SPVAL)THEN ! GRID2(I,J) = AVGPREC_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ! ELSE @@ -2526,7 +2526,7 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = ACPREC(I,J)*1000. ENDDO ENDDO @@ -2547,7 +2547,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2560,7 +2560,7 @@ SUBROUTINE SURFCE ! print*,'tinvstat in cont bucket= ',fld_info(cfld)%tinvstat ! do j=1,jend-jsta+1 ! jj = jsta+j-1 -! do i=isx,iex +! do i=ista,iend ! datapd(i,j,cfld) = GRID2(i,jj) ! enddo ! enddo @@ -2595,7 +2595,7 @@ SUBROUTINE SURFCE ! Chuang 3/29/2018: add continuous bucket !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF(AVGPREC_CONT(I,J) < SPVAL)THEN GRID2(I,J) = AVGPREC_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ELSE @@ -2616,7 +2616,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2650,7 +2650,7 @@ SUBROUTINE SURFCE IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF(AVGCPRATE(I,J) < SPVAL)THEN GRID1(I,J) = AVGCPRATE(I,J)* & FLOAT(ID(19)-ID(18))*3600.*1000./DTQ2 @@ -2661,7 +2661,7 @@ SUBROUTINE SURFCE ENDDO !! Chuang 3/29/2018: add continuous bucket ! DO J=JSTA,JEND -! do i=isx,iex +! do i=ista,iend ! IF(AVGCPRATE_CONT(I,J) < SPVAL)THEN ! GRID2(I,J) = AVGCPRATE_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ! ELSE @@ -2672,7 +2672,7 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = CUPREC(I,J)*1000. ENDDO ENDDO @@ -2686,7 +2686,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2698,7 +2698,7 @@ SUBROUTINE SURFCE ! fld_info(cfld)%tinvstat=IFHR ! do j=1,jend-jsta+1 ! jj = jsta+j-1 -! do i=isx,iex +! do i=ista,iend ! datapd(i,j,cfld) = GRID2(i,jj) ! enddo ! enddo @@ -2733,7 +2733,7 @@ SUBROUTINE SURFCE ! Chuang 3/29/2018: add continuous bucket !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF(AVGCPRATE_CONT(I,J) < SPVAL)THEN GRID2(I,J) = AVGCPRATE_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ELSE @@ -2753,7 +2753,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2788,7 +2788,7 @@ SUBROUTINE SURFCE IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + 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 @@ -2799,7 +2799,7 @@ SUBROUTINE SURFCE ENDDO !! Chuang 3/29/2018: add continuous bucket ! DO J=JSTA,JEND -! do i=isx,iex +! 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 @@ -2811,7 +2811,7 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = ANCPRC(I,J)*1000. ENDDO ENDDO @@ -2825,7 +2825,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2837,7 +2837,7 @@ SUBROUTINE SURFCE ! fld_info(cfld)%tinvstat=IFHR ! do j=1,jend-jsta+1 ! jj = jsta+j-1 -! do i=isx,iex +! do i=ista,iend ! datapd(i,j,cfld) = GRID2(i,jj) ! enddo ! enddo @@ -2872,7 +2872,7 @@ SUBROUTINE SURFCE ! Chuang 3/29/2018: add continuous bucket !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + 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 @@ -2893,7 +2893,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2905,7 +2905,7 @@ SUBROUTINE SURFCE IF (IGET(256)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF(LSPA(I,J)<=-1.0E-6)THEN GRID1(I,J) = ACPREC(I,J)*1000 ELSE @@ -2943,7 +2943,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2954,7 +2954,7 @@ SUBROUTINE SURFCE IF (IGET(035)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend ! GRID1(I,J) = ACSNOW(I,J)*1000. GRID1(I,J) = ACSNOW(I,J) ENDDO @@ -2988,7 +2988,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2999,7 +2999,7 @@ SUBROUTINE SURFCE IF (IGET(746)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = ACGRAUP(I,J) ENDDO ENDDO @@ -3032,7 +3032,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3043,7 +3043,7 @@ SUBROUTINE SURFCE IF (IGET(782)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = ACFRAIN(I,J) ENDDO ENDDO @@ -3076,7 +3076,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3087,7 +3087,7 @@ SUBROUTINE SURFCE IF (IGET(121)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend ! GRID1(I,J) = ACSNOM(I,J)*1000. GRID1(I,J) = ACSNOM(I,J) ENDDO @@ -3121,7 +3121,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3132,7 +3132,7 @@ SUBROUTINE SURFCE IF (IGET(405)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = SNOWFALL(I,J) ENDDO ENDDO @@ -3166,7 +3166,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3177,7 +3177,7 @@ SUBROUTINE SURFCE IF (IGET(122)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend ! GRID1(I,J) = SSROFF(I,J)*1000. GRID1(I,J) = SSROFF(I,J) ENDDO @@ -3219,7 +3219,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3230,7 +3230,7 @@ SUBROUTINE SURFCE IF (IGET(123)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend ! GRID1(I,J) = BGROFF(I,J)*1000. GRID1(I,J) = BGROFF(I,J) ENDDO @@ -3272,7 +3272,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3283,7 +3283,7 @@ SUBROUTINE SURFCE IF (IGET(343)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = RUNOFF(I,J) ENDDO ENDDO @@ -3319,7 +3319,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3331,7 +3331,7 @@ SUBROUTINE SURFCE IF (IGET(434)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF (IFHR == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3381,7 +3381,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3393,7 +3393,7 @@ SUBROUTINE SURFCE IF (IGET(435)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF (IFHR == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3448,7 +3448,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3459,7 +3459,7 @@ SUBROUTINE SURFCE IF (IGET(436)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF (IFHR == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3509,7 +3509,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3520,7 +3520,7 @@ SUBROUTINE SURFCE IF (IGET(437)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = SNOW_BUCKET(I,J) ENDDO ENDDO @@ -3567,7 +3567,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3578,7 +3578,7 @@ SUBROUTINE SURFCE IF (IGET(775)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = GRAUP_BUCKET(I,J) ENDDO ENDDO @@ -3625,7 +3625,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3638,7 +3638,7 @@ SUBROUTINE SURFCE IF (IGET(526)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3661,7 +3661,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3671,7 +3671,7 @@ SUBROUTINE SURFCE IF (IGET(527)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3694,7 +3694,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3704,7 +3704,7 @@ SUBROUTINE SURFCE IF (IGET(528)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3727,7 +3727,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3737,7 +3737,7 @@ SUBROUTINE SURFCE IF (IGET(529)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3761,7 +3761,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3771,7 +3771,7 @@ SUBROUTINE SURFCE IF (IGET(530)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3795,7 +3795,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3816,7 +3816,7 @@ SUBROUTINE SURFCE IF (IGET(160)>0) THEN !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IWX = IWX1(I,J) SNOW(I,J,1) = MOD(IWX,2) SLEET(I,J,1) = MOD(IWX,4)/2 @@ -3829,7 +3829,7 @@ SUBROUTINE SURFCE ! LOWEST WET BULB ZERO HEIGHT IF (IGET(247)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = ZWET(I,J) ENDDO ENDDO @@ -3839,7 +3839,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3860,7 +3860,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IWX = IWX1(I,J) SNOW(I,J,2) = MOD(IWX,2) SLEET(I,J,2) = MOD(IWX,4)/2 @@ -3883,7 +3883,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IWX = IWX1(I,J) SNOW(I,J,3) = MOD(IWX,2) SLEET(I,J,3) = MOD(IWX,4)/2 @@ -3899,7 +3899,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IWX = IWX1(I,J) SNOW(I,J,4) = MOD(IWX,2) SLEET(I,J,4) = MOD(IWX,4)/2 @@ -3915,7 +3915,7 @@ SUBROUTINE SURFCE else !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IWX1(I,J) = 0 ENDDO ENDDO @@ -3925,7 +3925,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IWX = IWX1(I,J) SNOW(I,J,5) = MOD(IWX,2) SLEET(I,J,5) = MOD(IWX,4)/2 @@ -3943,7 +3943,7 @@ SUBROUTINE SURFCE grid1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend if(prec(i,j) /= spval) GRID1(I,J) = DOMS(I,J) ENDDO ENDDO @@ -3953,7 +3953,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3962,7 +3962,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend if(prec(i,j)/=spval) GRID1(I,J) = DOMIP(I,J) ENDDO ENDDO @@ -3972,7 +3972,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3981,7 +3981,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + 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) @@ -3997,7 +3997,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4006,7 +4006,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend if(prec(i,j)/=spval)GRID1(I,J) = DOMR(I,J) ENDDO ENDDO @@ -4016,7 +4016,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4039,7 +4039,7 @@ SUBROUTINE SURFCE ! print *,'in SURFCE,me=',me,'IWX1=',IWX1(1:30,JSTA) !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IWX = IWX1(I,J) SNOW(I,J,1) = MOD(IWX,2) SLEET(I,J,1) = MOD(IWX,4)/2 @@ -4061,7 +4061,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IWX = IWX1(I,J) SNOW(I,J,2) = MOD(IWX,2) SLEET(I,J,2) = MOD(IWX,4)/2 @@ -4084,7 +4084,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IWX = IWX1(I,J) SNOW(I,J,3) = MOD(IWX,2) SLEET(I,J,3) = MOD(IWX,4)/2 @@ -4101,7 +4101,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IWX = IWX1(I,J) SNOW(I,J,4) = MOD(IWX,2) SLEET(I,J,4) = MOD(IWX,4)/2 @@ -4118,7 +4118,7 @@ SUBROUTINE SURFCE else !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IWX1(I,J) = 0 ENDDO ENDDO @@ -4128,7 +4128,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IWX = IWX1(I,J) SNOW(I,J,5) = MOD(IWX,2) SLEET(I,J,5) = MOD(IWX,4)/2 @@ -4178,7 +4178,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend if(avgprec(i,j) /= spval) GRID1(I,J) = DOMS(I,J) ENDDO ENDDO @@ -4196,7 +4196,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4225,7 +4225,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend if(avgprec(i,j)/=spval) GRID1(I,J) = DOMIP(I,J) ENDDO ENDDO @@ -4242,7 +4242,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4272,7 +4272,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + 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) @@ -4295,7 +4295,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4326,7 +4326,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend if(avgprec(i,j)/=spval) GRID1(I,J) = DOMR(I,J) ENDDO ENDDO @@ -4343,7 +4343,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4367,7 +4367,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend DOMS(I,J) = 0. !-- snow DOMR(I,J) = 0. !-- rain DOMZR(I,J) = 0. !-- freezing rain @@ -4376,7 +4376,7 @@ SUBROUTINE SURFCE ENDDO DO J=JSTA,JEND - do i=isx,iex + 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 @@ -4497,7 +4497,7 @@ SUBROUTINE SURFCE maxval(snow_bucket)*0.1,minval(snow_bucket)*0.1 DO J=JSTA,JEND - do i=isx,iex + 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 @@ -4514,7 +4514,7 @@ SUBROUTINE SURFCE icnt_snow_rain_mixed = 0 DO J=JSTA,JEND - do i=isx,iex + 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 @@ -4528,7 +4528,7 @@ SUBROUTINE SURFCE ! SNOW. !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=DOMS(I,J) ENDDO ENDDO @@ -4538,7 +4538,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4546,7 +4546,7 @@ SUBROUTINE SURFCE ! ICE PELLETS. !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = DOMIP(I,J) ! if (DOMIP(I,J) == 1) THEN ! print *, 'ICE PELLETS at I,J ', I, J @@ -4559,7 +4559,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4567,7 +4567,7 @@ SUBROUTINE SURFCE ! FREEZING RAIN. !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + 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) @@ -4581,7 +4581,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4589,7 +4589,7 @@ SUBROUTINE SURFCE ! RAIN. !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = DOMR(I,J) ENDDO ENDDO @@ -4599,7 +4599,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4629,7 +4629,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - do i=isx,iex + 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 @@ -4682,7 +4682,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - do i=isx,iex + 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 @@ -4735,7 +4735,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = SUBSHX(I,J)*RRNUM ENDDO ENDDO @@ -4784,7 +4784,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = SNOPCX(I,J)*RRNUM ENDDO ENDDO @@ -4833,7 +4833,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF(SFCUVX(I,J)/=SPVAL)THEN GRID1(I,J) = SFCUVX(I,J)*RRNUM ELSE @@ -4886,7 +4886,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = SFCUX(I,J)*RRNUM ENDDO ENDDO @@ -4935,7 +4935,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = SFCVX(I,J)*RRNUM ENDDO ENDDO @@ -4974,7 +4974,7 @@ SUBROUTINE SURFCE ! ACCUMULATED SURFACE EVAPORATION IF (IGET(047)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = SFCEVP(I,J)*1000. ENDDO ENDDO @@ -5016,7 +5016,7 @@ SUBROUTINE SURFCE ! ACCUMULATED POTENTIAL EVAPORATION IF (IGET(137)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = POTEVP(I,J)*1000. ENDDO ENDDO @@ -5057,7 +5057,7 @@ SUBROUTINE SURFCE ! ROUGHNESS LENGTH. IF (IGET(044)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = Z0(I,J) ENDDO ENDDO @@ -5071,7 +5071,7 @@ SUBROUTINE SURFCE ! FRICTION VELOCITY. IF (IGET(045)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = USTAR(I,J) ENDDO ENDDO @@ -5088,7 +5088,7 @@ SUBROUTINE SURFCE GRID1=spval CALL CALDRG(EGRID1(1,jsta_2l)) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF(USTAR(I,J) < spval) GRID1(I,J)=EGRID1(I,J) ENDDO ENDDO @@ -5101,7 +5101,7 @@ SUBROUTINE SURFCE write_cd: IF(IGET(922)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=CD10(I,J) ENDDO ENDDO @@ -5113,7 +5113,7 @@ SUBROUTINE SURFCE ENDIF write_cd write_ch: IF(IGET(923)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=CH10(I,J) ENDDO ENDDO @@ -5130,7 +5130,7 @@ SUBROUTINE SURFCE ! MODEL OUTPUT SURFACE U COMPONENT WIND STRESS. IF (IGET(900)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=MDLTAUX(I,J) ENDDO ENDDO @@ -5145,7 +5145,7 @@ SUBROUTINE SURFCE ! MODEL OUTPUT SURFACE V COMPONENT WIND STRESS IF (IGET(901)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=MDLTAUY(I,J) ENDDO ENDDO @@ -5167,7 +5167,7 @@ SUBROUTINE SURFCE ! dong for FV3, directly use model output IF (IGET(133)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=EGRID1(I,J) IF(MODELNAME == 'FV3R') THEN GRID1(I,J)=SFCUXI(I,J) @@ -5185,7 +5185,7 @@ SUBROUTINE SURFCE ! SURFACE V COMPONENT WIND STRESS IF (IGET(134)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=EGRID2(I,J) IF(MODELNAME == 'FV3R') THEN GRID1(I,J)=SFCVXI(I,J) @@ -5206,7 +5206,7 @@ SUBROUTINE SURFCE ! GRAVITY U COMPONENT WIND STRESS. IF (IGET(315)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = GTAUX(I,J) ENDDO ENDDO @@ -5244,7 +5244,7 @@ SUBROUTINE SURFCE ! SURFACE V COMPONENT WIND STRESS IF (IGET(316)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=GTAUY(I,J) ENDDO ENDDO @@ -5288,14 +5288,14 @@ SUBROUTINE SURFCE MODELNAME=='RAPR')THEN !4omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + 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=isx,iex + do i=ista,iend IF(TWBS(I,J) < spval) GRID1(I,J) = -TWBS(I,J) ENDDO ENDDO @@ -5315,14 +5315,14 @@ SUBROUTINE SURFCE MODELNAME=='RAPR')THEN !4omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + 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=isx,iex + do i=ista,iend IF(QWBS(I,J) < spval) GRID1(I,J) = -QWBS(I,J) ENDDO ENDDO @@ -5337,7 +5337,7 @@ SUBROUTINE SURFCE ! SURFACE EXCHANGE COEFF IF (IGET(169)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=SFCEXC(I,J) ENDDO ENDDO @@ -5351,7 +5351,7 @@ SUBROUTINE SURFCE ! GREEN VEG FRACTION IF (IGET(170)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=VEGFRC(I,J)*100. ENDDO ENDDO @@ -5366,7 +5366,7 @@ SUBROUTINE SURFCE ! MIN GREEN VEG FRACTION IF (IGET(726)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=shdmin(I,J)*100. ENDDO ENDDO @@ -5380,7 +5380,7 @@ SUBROUTINE SURFCE ! MAX GREEN VEG FRACTION IF (IGET(729)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=shdmax(I,J)*100. ENDDO ENDDO @@ -5397,7 +5397,7 @@ SUBROUTINE SURFCE IF (iSF_SURFACE_PHYSICS == 2 .OR. MODELNAME=='RAPR') THEN IF (IGET(254)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend IF (MODELNAME=='RAPR')THEN GRID1(I,J)=LAI(I,J) ELSE @@ -5417,7 +5417,7 @@ SUBROUTINE SURFCE ! INSTANTANEOUS GROUND HEAT FLUX IF (IGET(152)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=GRNFLX(I,J) ENDDO ENDDO @@ -5430,7 +5430,7 @@ SUBROUTINE SURFCE ! VEGETATION TYPE IF (IGET(218)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = FLOAT(IVGTYP(I,J)) ENDDO ENDDO @@ -5444,7 +5444,7 @@ SUBROUTINE SURFCE ! SOIL TYPE IF (IGET(219)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = FLOAT(ISLTYP(I,J)) ENDDO ENDDO @@ -5457,7 +5457,7 @@ SUBROUTINE SURFCE ! SLOPE TYPE IF (IGET(223)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = FLOAT(ISLOPE(I,J)) ENDDO ENDDO @@ -5483,7 +5483,7 @@ SUBROUTINE SURFCE 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)) DO J=JSTA,JEND - do i=isx,iex + 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 @@ -5526,7 +5526,7 @@ SUBROUTINE SURFCE IF (IGET(220)>0 )THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = GC(I,J) ENDDO ENDDO @@ -5539,7 +5539,7 @@ SUBROUTINE SURFCE IF (IGET(234)>0 )THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = RSMIN(I,J) ENDDO ENDDO @@ -5552,7 +5552,7 @@ SUBROUTINE SURFCE IF (IGET(235)>0 )THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = FLOAT(NROOTS(I,J)) ENDDO ENDDO @@ -5565,7 +5565,7 @@ SUBROUTINE SURFCE IF (IGET(236)>0 )THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = SMCWLT(I,J) ENDDO ENDDO @@ -5578,7 +5578,7 @@ SUBROUTINE SURFCE IF (IGET(237)>0 )THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = SMCREF(I,J) ENDDO ENDDO @@ -5591,7 +5591,7 @@ SUBROUTINE SURFCE IF (IGET(238)>0 )THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = RCS(I,J) ENDDO ENDDO @@ -5604,7 +5604,7 @@ SUBROUTINE SURFCE IF (IGET(239)>0 )THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = RCT(I,J) ENDDO ENDDO @@ -5617,7 +5617,7 @@ SUBROUTINE SURFCE IF (IGET(240)>0 )THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = RCQ(I,J) ENDDO ENDDO @@ -5630,7 +5630,7 @@ SUBROUTINE SURFCE IF (IGET(241)>0 )THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = RCSOIL(I,J) ENDDO ENDDO @@ -5659,7 +5659,7 @@ SUBROUTINE SURFCE IF(IGET(236)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = smcwlt(i,j) ! IF(isltyp(i,j)/=0)THEN ! GRID1(I,J) = WLTSMC(isltyp(i,j)) @@ -5674,7 +5674,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5684,7 +5684,7 @@ SUBROUTINE SURFCE IF(IGET(397)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = fieldcapa(i,j) ! IF(isltyp(i,j)/=0)THEN ! GRID1(I,J) = REFSMC(isltyp(i,j)) @@ -5699,7 +5699,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5709,7 +5709,7 @@ SUBROUTINE SURFCE IF(IGET(396)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = suntime(i,j) ENDDO ENDDO @@ -5743,7 +5743,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5753,7 +5753,7 @@ SUBROUTINE SURFCE IF(IGET(517)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = avgpotevp(i,j) ENDDO ENDDO @@ -5787,7 +5787,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=isx,iex + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5800,7 +5800,7 @@ SUBROUTINE SURFCE IF (IGET(282)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J) = PT ENDDO ENDDO @@ -5814,7 +5814,7 @@ SUBROUTINE SURFCE ! PRESSURE THICKNESS REQUESTED BY CMAQ IF (IGET(283)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=PDTOP ENDDO ENDDO @@ -5838,7 +5838,7 @@ SUBROUTINE SURFCE ! SIGMA PRESSURE THICKNESS REQUESTED BY CMAQ IF (IGET(273)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=PD(I,J) ENDDO ENDDO @@ -5863,7 +5863,7 @@ SUBROUTINE SURFCE ! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR MASS REQUESTED FOR CMAQ IF (IGET(503)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=AKHSAVG(I,J) ENDDO ENDDO @@ -5888,7 +5888,7 @@ SUBROUTINE SURFCE ! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR WIND REQUESTED FOR CMAQ IF (IGET(504)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=AKMSAVG(I,J) ENDDO ENDDO @@ -5915,7 +5915,7 @@ SUBROUTINE SURFCE ! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR MASS REQUESTED FOR CMAQ IF (IGET(503)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=AKHSAVG(I,J) ENDDO ENDDO @@ -5940,7 +5940,7 @@ SUBROUTINE SURFCE ! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR WIND REQUESTED FOR CMAQ IF (IGET(504)>0) THEN DO J=JSTA,JEND - do i=isx,iex + do i=ista,iend GRID1(I,J)=AKMSAVG(I,J) ENDDO ENDDO From 90bbc57415d0d53588a5cbb2742f1fe2295d3305 Mon Sep 17 00:00:00 2001 From: wx15gv Date: Mon, 3 May 2021 23:00:49 +0000 Subject: [PATCH 06/77] test commit of new base into clone --- sorc/ncep_post.fd/CLDRAD.f | 480 +++++++++++++------------------ sorc/ncep_post.fd/CTLBLK.f | 5 +- sorc/ncep_post.fd/grib2_module.f | 8 - 3 files changed, 193 insertions(+), 300 deletions(-) diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index 2b0e5b6a9..749e4f3bf 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -127,11 +127,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, & -<<<<<<< HEAD - JM, LM, gocart_on, me,ista,iend -======= JM, LM, gocart_on, me, rdaod ->>>>>>> upstream/develop use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD use gridspec_mod, only: dyval, gridtype use cmassi_mod, only: TRAD_ice @@ -148,10 +144,10 @@ SUBROUTINE CLDRAD ! ! LOGICAL,dimension(im,jm) :: NEED INTEGER :: lcbot,lctop,jc,ic !bsf - INTEGER,dimension(ista:iend,jsta:jend) :: IBOTT, IBOTCu, IBOTDCu, IBOTSCu, IBOTGr, & + INTEGER,dimension(im,jsta:jend) :: IBOTT, IBOTCu, IBOTDCu, IBOTSCu, IBOTGr, & ITOPT, ITOPCu, ITOPDCu, ITOPSCu, ITOPGr REAL,dimension(im,jm) :: GRID1 - REAL,dimension(ista:iend,jsta:jend) :: GRID2, EGRID1, EGRID2, EGRID3, & + REAL,dimension(im,jsta:jend) :: GRID2, EGRID1, EGRID2, EGRID3, & CLDP, CLDZ, CLDT, CLDZCu REAL,dimension(lm) :: RHB, watericetotal, pabovesfc REAL :: watericemax, wimin, zcldbase, zcldtop, zpbltop, & @@ -168,7 +164,7 @@ SUBROUTINE CLDRAD real,dimension(im,jm) :: ceil ! B ZHOU: For aviation: - REAL, dimension(ista:iend,jsta:jend) :: TCLD, CEILING + REAL, dimension(im,jsta:jend) :: TCLD, CEILING real CU_ir(LM), q_conv !bsf !jw integer I,J,L,K,IBOT,ITCLOD,LBOT,LTOP,ITRDSW,ITRDLW, & @@ -178,8 +174,8 @@ SUBROUTINE CLDRAD ! real FULL_CLD(IM,JM) !-- Must be dimensioned for the full domain ! - real dummy(ista:iend,jsta:jend) - integer idummy(ista:iend,jsta:jend) + real dummy(IM,jsta:jend) + integer idummy(IM,jsta:jend) ! ! --- Revision added for GOCART --- @@ -224,7 +220,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(ista:iend,jsta:jend) :: P1D,T1D,Q1D,EGRID4 + REAL,dimension(im,jsta:jend) :: P1D,T1D,Q1D,EGRID4 ! REAL, allocatable :: RH3D(:,:,:) ! RELATIVE HUMIDITY real, allocatable:: rdrh(:,:,:) integer, allocatable :: ihh(:,:,:) @@ -232,10 +228,10 @@ SUBROUTINE CLDRAD INTEGER :: IH1, IH2 INTEGER :: IOS, INDX, ISSAM, ISSCM, ISUSO, IWASO, ISOOT, NBIN REAL :: CCDRY, CCWET, SSAM, SSCM - 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,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 :: ANG1, ANG2 INTEGER :: INDX_EXT(nAero), INDX_SCA(nAero) LOGICAL :: LAEROPT, LEXT, LSCA, LASY @@ -275,7 +271,7 @@ SUBROUTINE CLDRAD IF (IGET(030)>0.OR.IGET(572)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EGRID1(I,J) = SPVAL ENDDO ENDDO @@ -285,14 +281,14 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'RAPR') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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=ista,iend + DO I=1,IM IF(EGRID1(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) + TFRZ ENDDO ENDDO @@ -305,7 +301,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -320,7 +316,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im if (grid1(i,jj) /= spval) grid1(i,jj) = grid1(i,jj) - tfrz datapd(i,j,cfld) = GRID1(i,jj) enddo @@ -346,7 +342,7 @@ SUBROUTINE CLDRAD EGRID3,dummy,dummy) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(FIS(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -357,7 +353,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -374,7 +370,7 @@ SUBROUTINE CLDRAD IF ( (LVLS(1,IGET(032)) > 0) )THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(FIS(I,J) < SPVAL) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -388,7 +384,7 @@ SUBROUTINE CLDRAD EGRID3,dummy,dummy) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(FIS(I,J) < SPVAL) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -396,7 +392,7 @@ SUBROUTINE CLDRAD CALL BOUND(GRID1,D00,H99999) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(FIS(I,J) < SPVAL) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -406,7 +402,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -422,7 +418,7 @@ SUBROUTINE CLDRAD GRID1 = spval CALL CALPW(GRID1(1,jsta),1) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(FIS(I,J) >= SPVAL) GRID1(I,J)=spval END DO END DO @@ -433,7 +429,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -452,7 +448,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -471,7 +467,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -484,13 +480,8 @@ SUBROUTINE CLDRAD GRID2 = spval IF (MODELNAME == 'RAPR') THEN DO J=JSTA,JEND -<<<<<<< HEAD - DO I=ista,iend - GRID1(I,J) = LWP(I,J)/1000.0 ! use WRF-diagnosed value -======= DO I=1,IM IF(LWP(I,J) < SPVAL) GRID1(I,J) = LWP(I,J)/1000.0 ! use WRF-diagnosed value ->>>>>>> upstream/develop ENDDO ENDDO ELSE @@ -500,12 +491,8 @@ SUBROUTINE CLDRAD CALL CALPW(GRID2(1,jsta),3) !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD - DO I=ista,iend -======= DO I=1,IM IF(GRID1(I,J)>>>>>> upstream/develop GRID1(I,J) = GRID1(I,J) + GRID2(I,J) ELSE GRID1(I,J) = SPVAL @@ -523,7 +510,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -536,7 +523,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -550,13 +537,8 @@ SUBROUTINE CLDRAD GRID1 = spval IF (MODELNAME == 'RAPR') THEN DO J=JSTA,JEND -<<<<<<< HEAD - DO I=ista,iend - GRID1(I,J) = IWP(I,J)/1000.0 ! use WRF-diagnosed value -======= DO I=1,IM IF(IWP(I,J) < SPVAL) GRID1(I,J) = IWP(I,J)/1000.0 ! use WRF-diagnosed value ->>>>>>> upstream/develop ENDDO ENDDO ELSE @@ -569,7 +551,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -586,7 +568,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -603,7 +585,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -621,7 +603,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -639,7 +621,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -656,7 +638,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -673,7 +655,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -689,7 +671,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -705,7 +687,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -722,13 +704,8 @@ SUBROUTINE CLDRAD ENDIF !$omp parallel do DO J=JSTA,JEND -<<<<<<< HEAD - DO I=ista,iend - GRID1(I,J) = GRID1(I,J)*RRNUM -======= DO I=1,IM IF(GRID1(I,J) < SPVAL) GRID1(I,J) = GRID1(I,J)*RRNUM ->>>>>>> upstream/develop ENDDO ENDDO ID(1:25)=0 @@ -760,7 +737,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -777,13 +754,8 @@ SUBROUTINE CLDRAD ENDIF !$omp parallel do DO J=JSTA,JEND -<<<<<<< HEAD - DO I=ista,iend - GRID1(I,J) = GRID1(I,J)*RRNUM -======= DO I=1,IM IF(GRID1(I,J) < SPVAL) GRID1(I,J) = GRID1(I,J)*RRNUM ->>>>>>> upstream/develop ENDDO ENDDO ID(1:25)=0 @@ -815,7 +787,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -851,7 +823,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -861,7 +833,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=ista,iend + DO I=1,IM GRID1(I,J)=-5000. GRID2(I,J)=-5000. !-- Search for the base first, then look for the top if supercooled liquid exists @@ -901,7 +873,7 @@ SUBROUTINE CLDRAD IF (IGET(288)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=GRID2(I,J) ENDDO ENDDO @@ -911,7 +883,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -924,7 +896,7 @@ 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=ista,iend + DO I=1,IM GRID1(I,J) = CLDEFI(I,J) ENDDO ENDDO @@ -943,7 +915,7 @@ SUBROUTINE CLDRAD ! also a method for cloud ceiling height ! DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM CFRACL(I,J)=0. CFRACM(I,J)=0. CFRACH(I,J)=0. @@ -963,7 +935,7 @@ SUBROUTINE CLDRAD ! write (0,*) 'numr,dyval,DY_m=',numr,dyval,DY_m DO L=LM,1,-1 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(CFR(I,J,L)=PTOP_LOW) THEN @@ -1048,7 +1020,7 @@ SUBROUTINE CLDRAD IF (IGET(799)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=0.0 DO K = 1,LM IF (ZMID(I,J,LM-K+1) <= PBLH(I,J)+1000.0) THEN @@ -1068,7 +1040,7 @@ SUBROUTINE CLDRAD IF (IGET(037) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(CFRACL(I,J) < SPVAL) then GRID1(I,J) = CFRACL(I,J)*100. else @@ -1082,7 +1054,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1093,7 +1065,7 @@ SUBROUTINE CLDRAD IF (IGET(300) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(AVGCFRACL(I,J) < SPVAL) then GRID1(I,J) = AVGCFRACL(I,J)*100. else @@ -1132,7 +1104,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1144,7 +1116,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(CFRACM(I,J) < SPVAL) then GRID1(I,J) = CFRACM(I,J)*100. else @@ -1158,7 +1130,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1169,7 +1141,7 @@ SUBROUTINE CLDRAD IF (IGET(301) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ABS(AVGCFRACM(I,J)-SPVAL)>SMALL)THEN GRID1(I,J) = AVGCFRACM(I,J)*100. ELSE @@ -1208,7 +1180,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1220,7 +1192,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(CFRACH(I,J) < SPVAL) then GRID1(I,J) = CFRACH(I,J)*100. else @@ -1234,7 +1206,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1246,7 +1218,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(AVGCFRACH(I,J) < SPVAL) then GRID1(I,J) = AVGCFRACH(I,J)*100. else @@ -1285,7 +1257,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1298,7 +1270,7 @@ SUBROUTINE CLDRAD IF(MODELNAME=='NCAR' .OR. MODELNAME=='RAPR')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(i,j) = SPVAL egrid1(i,j)=0. do l = 1,LM @@ -1310,7 +1282,7 @@ SUBROUTINE CLDRAD ELSE IF (MODELNAME=='NMM'.OR.MODELNAME=='FV3R' & .OR. MODELNAME=='GFS')THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! 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))* & @@ -1322,7 +1294,7 @@ SUBROUTINE CLDRAD END IF !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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 @@ -1336,7 +1308,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1350,7 +1322,7 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ABS(AVGTCDC(I,J)-SPVAL) > SMALL) then GRID1(I,J) = AVGTCDC(I,J)*100. else @@ -1361,7 +1333,7 @@ SUBROUTINE CLDRAD ELSE IF(MODELNAME == 'NMM')THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! RSUM = NCFRST(I,J)+NCFRCV(I,J) ! IF (RSUM>0.0) THEN ! EGRID1(I,J)=(ACFRST(I,J)+ACFRCV(I,J))/RSUM @@ -1415,7 +1387,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1428,12 +1400,8 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND -<<<<<<< HEAD - DO I=ista,iend -======= DO I=1,IM IF (NCFRST(I,J)>>>>>> upstream/develop IF (NCFRST(I,J)>0.0) THEN GRID1(I,J) = ACFRST(I,J)/NCFRST(I,J)*100. ELSE @@ -1484,12 +1452,8 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND -<<<<<<< HEAD - DO I=ista,iend -======= DO I=1,IM IF (NCFRCV(I,J)>>>>>> upstream/develop IF (NCFRCV(I,J)>0.0) THEN GRID1(I,J) = ACFRCV(I,J)/NCFRCV(I,J)*100. ELSE @@ -1548,7 +1512,7 @@ SUBROUTINE CLDRAD !--- Rain is not part of cloud, only cloud water + cloud ice + snow ! DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! !--- Various convective cloud base & cloud top levels ! @@ -1679,7 +1643,7 @@ SUBROUTINE CLDRAD IF (IGET(758)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDZCu(I,J) ENDDO ENDDO @@ -1698,7 +1662,7 @@ SUBROUTINE CLDRAD ! IF ((IGET(148)>0) .OR. (IGET(178)>0) .OR.(IGET(260)>0) ) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IBOT=IBOTT(I,J) !-- Cloud base ("bottoms") IF(MODELNAME == 'RAPR') then IF (IBOT <= 0) THEN @@ -1729,7 +1693,7 @@ SUBROUTINE CLDRAD ! CLOUD BOTTOM PRESSURE IF (IGET(148)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -1743,7 +1707,7 @@ SUBROUTINE CLDRAD IF (IGET(178)>0) THEN !--- Parameter was set to 148 in operational code (Ferrier, Feb '02) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -1782,7 +1746,7 @@ SUBROUTINE CLDRAD DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! !- imported from RUC post IF(MODELNAME == 'RAPR') then @@ -1974,7 +1938,7 @@ SUBROUTINE CLDRAD nlifr = 0 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM zcld = CLDZ(i,j) - FIS(I,J)*GI if (CLDZ(i,j)>=0..and.zcld<160.) nlifr = nlifr+1 end do @@ -1985,7 +1949,7 @@ SUBROUTINE CLDRAD IF (IGET(408)>0) THEN !!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -2009,7 +1973,7 @@ SUBROUTINE CLDRAD ceiling_thresh_cldfra = 0.5 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ceil(I,J) = SPVAL zceil = SPVAL cldfra_max = 0. @@ -2080,7 +2044,7 @@ SUBROUTINE CLDRAD ! proceed to gridding DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ceil(I,J) ENDDO ENDDO @@ -2110,7 +2074,7 @@ SUBROUTINE CLDRAD const1 = 3.912 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ceil(I,J) = SPVAL zceil = SPVAL zceil1 = SPVAL @@ -2228,7 +2192,7 @@ SUBROUTINE CLDRAD ! layer. numr = 1 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ceil_min = max( ceil(I,J)-FIS(I,J)*GI , 5.0) ! ceil_min in AGL do jc = max(JSTA,J-numr),min(JEND,J+numr) do ic = max(1,I-numr),min(IM,I+numr) @@ -2254,7 +2218,7 @@ SUBROUTINE CLDRAD IF (IGET(711)>0) THEN !!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -2269,7 +2233,7 @@ SUBROUTINE CLDRAD IF (IGET(798)>0) THEN !!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -2287,7 +2251,7 @@ SUBROUTINE CLDRAD IF (IGET(260)>0) THEN CALL CALCEILING(CLDZ,TCLD,CEILING) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CEILING(I,J) ENDDO ENDDO @@ -2301,7 +2265,7 @@ SUBROUTINE CLDRAD IF (IGET(261) > 0) THEN CALL CALFLTCND(CEILING,GRID1(1,jsta)) ! DO J=JSTA,JEND -! DO I=ista,iend +! DO I=1,IM ! GRID1(I,J) = FLTCND(I,J) ! ENDDO ! ENDDO @@ -2311,7 +2275,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2324,13 +2288,13 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PBOT(I,J) ENDDO ENDDO ELSE DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IBOT=IBOTCu(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2346,7 +2310,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2357,7 +2321,7 @@ SUBROUTINE CLDRAD ! IF (IGET(192) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IBOT=IBOTDCu(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2376,7 +2340,7 @@ SUBROUTINE CLDRAD ! IF (IGET(190) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IBOT=IBOTSCu(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2395,7 +2359,7 @@ SUBROUTINE CLDRAD ! IF (IGET(194) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IBOT=IBOTGr(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2415,7 +2379,7 @@ SUBROUTINE CLDRAD ! IF (IGET(303) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! IF(PBOTL(I,J) > SMALL)THEN GRID1(I,J) = PBOTL(I,J) ! ELSE @@ -2458,7 +2422,7 @@ SUBROUTINE CLDRAD ! IF (IGET(306) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(PBOTM(I,J) > SMALL)THEN GRID1(I,J) = PBOTM(I,J) ELSE @@ -2501,7 +2465,7 @@ SUBROUTINE CLDRAD ! IF (IGET(309) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(PBOTH(I,J) > SMALL)THEN GRID1(I,J) = PBOTH(I,J) ELSE @@ -2550,7 +2514,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=ista,iend + DO I=1,IM 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=ista,iend + DO I=1,IM GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -2600,7 +2564,7 @@ SUBROUTINE CLDRAD ! IF (IGET(179)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -2618,7 +2582,7 @@ SUBROUTINE CLDRAD Cloud_def_p = 0.0000001 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! imported from RUC post ! Cloud top zcldtop = -5000. @@ -2682,7 +2646,7 @@ SUBROUTINE CLDRAD ! IF (IGET(406)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -2696,7 +2660,7 @@ SUBROUTINE CLDRAD ! IF (IGET(409)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -2712,7 +2676,7 @@ SUBROUTINE CLDRAD ! IF (IGET(168)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDT(I,J) ENDDO ENDDO @@ -2728,7 +2692,7 @@ SUBROUTINE CLDRAD num_thick=0 ! for debug GRID1=spval DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM opdepth=0. llmh=nint(lmh(i,j)) !bsf - start @@ -2828,13 +2792,13 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PTOP(I,J) ENDDO ENDDO ELSE DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ITOP=ITOPCu(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2850,7 +2814,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2861,7 +2825,7 @@ SUBROUTINE CLDRAD ! IF (IGET(193) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ITOP=ITOPDCu(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2880,7 +2844,7 @@ SUBROUTINE CLDRAD ! IF (IGET(191) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ITOP=ITOPSCu(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2900,7 +2864,7 @@ SUBROUTINE CLDRAD ! IF (IGET(195) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ITOP=ITOPGr(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2920,7 +2884,7 @@ SUBROUTINE CLDRAD ! IF (IGET(304) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(PTOPL(I,J) > SMALL)THEN GRID1(I,J) = PTOPL(I,J) ELSE @@ -2963,7 +2927,7 @@ SUBROUTINE CLDRAD ! IF (IGET(307) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PTOPM(I,J) ENDDO ENDDO @@ -3002,7 +2966,7 @@ SUBROUTINE CLDRAD ! IF (IGET(310) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PTOPH(I,J) ENDDO ENDDO @@ -3042,7 +3006,7 @@ SUBROUTINE CLDRAD ! IF (IGET(305) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = TTOPL(I,J) ENDDO ENDDO @@ -3081,7 +3045,7 @@ SUBROUTINE CLDRAD ! IF (IGET(308) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = TTOPM(I,J) ENDDO ENDDO @@ -3120,7 +3084,7 @@ SUBROUTINE CLDRAD ! IF (IGET(311) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = TTOPH(I,J) ENDDO ENDDO @@ -3160,7 +3124,7 @@ SUBROUTINE CLDRAD IF (IGET(196) > 0.or.IGET(570)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(CNVCFR(I,J)/=SPVAL)GRID1(I,J)=100.*CNVCFR(I,J) !-- convert to percent ENDDO ENDDO @@ -3184,7 +3148,7 @@ SUBROUTINE CLDRAD IF (IGET(342) > 0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(PBLCFR(I,J)/=SPVAL)GRID1(I,J)=100.*PBLCFR(I,J) !-- convert to percent ENDDO ENDDO @@ -3224,7 +3188,7 @@ SUBROUTINE CLDRAD ! IF (IGET(313) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=cldwork(I,J) ENDDO ENDDO @@ -3276,7 +3240,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ASWIN(I,J)/=SPVAL)THEN GRID1(I,J) = ASWIN(I,J)*RRNUM ELSE @@ -3329,7 +3293,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(AUVBIN(I,J)/=SPVAL)THEN GRID1(I,J) = AUVBIN(I,J)*RRNUM ELSE @@ -3383,7 +3347,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(AUVBINC(I,J)/=SPVAL)THEN GRID1(I,J) = AUVBINC(I,J)*RRNUM ELSE @@ -3436,7 +3400,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ALWIN(I,J)/=SPVAL)THEN GRID1(I,J) = ALWIN(I,J)*RRNUM ELSE @@ -3488,7 +3452,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ASWOUT(I,J)/=SPVAL)THEN GRID1(I,J) = -1.0*ASWOUT(I,J)*RRNUM ELSE @@ -3540,7 +3504,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ALWOUT(I,J)/=SPVAL)THEN GRID1(I,J) = -1.0*ALWOUT(I,J)*RRNUM ELSE @@ -3592,7 +3556,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ASWTOA(I,J)/=SPVAL)THEN GRID1(I,J) = ASWTOA(I,J)*RRNUM ELSE @@ -3644,7 +3608,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ALWTOA(I,J)/=SPVAL)THEN GRID1(I,J) = ALWTOA(I,J)*RRNUM ELSE @@ -3690,7 +3654,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RLWTOA(I,J) ENDDO ENDDO @@ -3709,7 +3673,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(RLWTOA(I,J) < SPVAL) & & GRID1(I,J) = (RLWTOA(I,J)*STBOL)**0.25 ENDDO @@ -3726,12 +3690,8 @@ SUBROUTINE CLDRAD IF (IGET(156)>0) THEN GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD - DO I=ista,iend -======= DO I=1,IM IF(RSWIN(I,J)>>>>>> upstream/develop IF(CZMEAN(I,J)>1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE @@ -3754,7 +3714,7 @@ SUBROUTINE CLDRAD ! dong add missing value to DLWRF GRID1 = spval DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(MODELNAME=='RSM' .OR. MODELNAME == 'RAPR') THEN !add by Binbin: RSM has direct RLWIN output GRID1(I,J)=RLWIN(I,J) ELSE @@ -3784,12 +3744,8 @@ SUBROUTINE CLDRAD GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD - DO I=ista,iend -======= DO I=1,IM IF(RSWOUT(I,J)>>>>>> upstream/develop IF(CZMEAN(I,J)>1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE @@ -3810,7 +3766,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky upwelling SW at the surface IF (IGET(743)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWUPBC(I,J) ENDDO ENDDO @@ -3825,7 +3781,7 @@ SUBROUTINE CLDRAD IF (IGET(142)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RADOT(I,J) ENDDO ENDDO @@ -3839,7 +3795,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky downwelling LW at the surface IF (IGET(744)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = LWDNBC(I,J) ENDDO ENDDO @@ -3853,7 +3809,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky upwelling LW at the surface IF (IGET(745)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = LWUPBC(I,J) ENDDO ENDDO @@ -3868,7 +3824,7 @@ SUBROUTINE CLDRAD IF (IGET(740)>0) THEN ! print *,"GETTING INTO MEAN_FRP PART" DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = MEAN_FRP(I,J) ENDDO ENDDO @@ -3885,12 +3841,8 @@ SUBROUTINE CLDRAD GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD - DO I=ista,iend -======= DO I=1,IM IF(RSWINC(I,J)>>>>>> upstream/develop IF(CZMEAN(I,J)>1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE @@ -3910,7 +3862,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky downwelling SW at surface (GSD version) IF (IGET(742)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWDNBC(I,J) ENDDO ENDDO @@ -3925,7 +3877,7 @@ SUBROUTINE CLDRAD IF (IGET(772)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWDDNI(I,J) ENDDO ENDDO @@ -3939,7 +3891,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky SWDDNI IF (IGET(796)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWDDNIC(I,J) ENDDO ENDDO @@ -3954,7 +3906,7 @@ SUBROUTINE CLDRAD IF (IGET(773)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWDDIF(I,J) ENDDO ENDDO @@ -3968,7 +3920,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky SWDDIF IF (IGET(797)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWDDIFC(I,J) ENDDO ENDDO @@ -3982,7 +3934,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED INCOMING CLEARSKY SW RADIATION AT THE SURFACE. IF (IGET(383)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ASWINC(I,J) ENDDO ENDDO @@ -4020,7 +3972,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY SW RADIATION AT THE SURFACE. IF (IGET(386)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ASWOUTC(I,J) ENDDO ENDDO @@ -4058,7 +4010,7 @@ SUBROUTINE CLDRAD ! Instantaneous all-sky outgoing SW flux at the model top IF (IGET(719)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWUPT(I,J) ENDDO ENDDO @@ -4072,7 +4024,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY SW RADIATION AT THE MODEL TOP IF (IGET(387)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ASWTOAC(I,J) ENDDO ENDDO @@ -4110,7 +4062,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED INCOMING SW RADIATION AT THE MODEL TOP IF (IGET(388)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ASWINTOA(I,J) ENDDO ENDDO @@ -4148,7 +4100,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED INCOMING CLEARSKY LW RADIATION AT THE SURFACE IF (IGET(382)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ALWINC(I,J) ENDDO ENDDO @@ -4186,7 +4138,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY LW RADIATION AT THE SURFACE IF (IGET(384)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ALWOUTC(I,J) ENDDO ENDDO @@ -4224,7 +4176,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY LW RADIATION AT THE MODEL TOP IF (IGET(385)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ALWTOAC(I,J) ENDDO ENDDO @@ -4262,7 +4214,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE BEAM DOWNWARD SOLAR FLUX IF (IGET(401)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = AVISBEAMSWIN(I,J) ENDDO ENDDO @@ -4302,7 +4254,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE DIFFUSE DOWNWARD SOLAR FLUX IF (IGET(402)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = AVISDIFFSWIN(I,J) ENDDO ENDDO @@ -4341,7 +4293,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE BEAM DOWNWARD SOLAR FLUX IF (IGET(403)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = AIRBEAMSWIN(I,J) ENDDO ENDDO @@ -4380,7 +4332,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE DIFFUSE DOWNWARD SOLAR FLUX IF (IGET(404)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = AIRDIFFSWIN(I,J) ENDDO ENDDO @@ -4501,7 +4453,7 @@ SUBROUTINE CLDRAD !2D AEROSOL OPTICAL DEPTH AT 550 NM IF (IGET(715)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM grid1(i,j)=taod5502d(i,j) ENDDO ENDDO @@ -4515,7 +4467,7 @@ SUBROUTINE CLDRAD !AEROSOL ASYMMETRY FACTOR IF (IGET(716)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM grid1(i,j)=aerasy2d(i,j) ENDDO ENDDO @@ -4529,7 +4481,7 @@ SUBROUTINE CLDRAD !AEROSOL SINGLE-SCATTERING ALBEDO IF (IGET(717)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM grid1(i,j)=aerssa2d(i,j) ENDDO ENDDO @@ -4723,13 +4675,13 @@ SUBROUTINE CLDRAD !!! COMPUTES RELATIVE HUMIDITY AND RDRH ! allocate (RH3D(im,jsta:jend,lm)) - allocate (rdrh(ista:iend,jsta:jend,lm)) - allocate (ihh(ista:iend,jsta:jend,lm)) + allocate (rdrh(im,jsta:jend,lm)) + allocate (ihh(im,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=ista,iend + DO I=1,IM P1D(I,J) = PMID(I,J,LL) T1D(I,J) = T(I,J,LL) Q1D(I,J) = Q(I,J,LL) @@ -4737,7 +4689,7 @@ SUBROUTINE CLDRAD ENDDO CALL CALRH(P1D,T1D,Q1D,EGRID4) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! RH3D(I,J,LL) = EGRID4(I,J) RH3D = EGRID4(I,J) ! DETERMINE RDRH (wgt for IH2) and IHH (index for IH2) @@ -4825,7 +4777,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM DO L=1,LM DO N=1, NBIN_DU EXT01 = EXTRHD_DU(1,N,IB) @@ -4852,7 +4804,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM DO L=1,LM ih1 = ihh(I,J,L) ih2 = ih1 + 1 @@ -4886,7 +4838,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4919,7 +4871,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4951,7 +4903,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4981,7 +4933,7 @@ SUBROUTINE CLDRAD SCA=SPVAL ASY=SPVAL DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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) @@ -5013,7 +4965,7 @@ SUBROUTINE CLDRAD IF (IB == 2 ) THEN !! AOD AT 440 NM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM AOD_440(I,J) = AOD(I,J) ENDDO ! I-loop ENDDO ! J-loop @@ -5022,7 +4974,7 @@ SUBROUTINE CLDRAD IF (IB == 5 ) THEN !! AOD AT 860 NM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM AOD_860(I,J) = AOD(I,J) ENDDO ! I-loop ENDDO ! J-loop @@ -5033,7 +4985,7 @@ SUBROUTINE CLDRAD IF ( IGET(INDX) > 0) THEN !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im GRID1(i,j) = AOD(i,j) enddo enddo @@ -5053,12 +5005,8 @@ SUBROUTINE CLDRAD GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD - DO I=ista,iend -======= DO I=1,IM IF(SCA2D(I,J)>>>>>> upstream/develop IF ( SCA2D(I,J) > 0.0 ) THEN ASY2D(I,J) = ASY2D(I,J) / SCA2D(I,J) ELSE @@ -5081,12 +5029,8 @@ SUBROUTINE CLDRAD GRID1 = SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD - DO I=ista,iend -======= DO I=1,IM IF(AOD(I,J)>>>>>> upstream/develop IF ( AOD(I,J) > 0.0 ) THEN SCA2D(I,J) = SCA2D(I,J) / AOD(I,J) ELSE @@ -5116,7 +5060,7 @@ SUBROUTINE CLDRAD IF ( IGET(650) > 0 ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=SCA2D(I,J) ENDDO ENDDO @@ -5135,7 +5079,7 @@ SUBROUTINE CLDRAD IF ( IGET(JJ) > 0) THEN ! EXT AOD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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) @@ -5156,7 +5100,7 @@ SUBROUTINE CLDRAD IF ( IGET(JJ) > 0) THEN ! SCA AOD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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) @@ -5185,7 +5129,7 @@ SUBROUTINE CLDRAD ANG2 = LOG ( 860. / 440. ) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF (AOD_860(I,J) > 0.) THEN ANG1 = LOG( AOD_440(I,J)/AOD_860(I,J) ) ANGST(I,J) = ANG1 / ANG2 @@ -5210,13 +5154,8 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND -<<<<<<< HEAD - DO I = ista,iend - GRID1(I,J) = DUEM(I,J,1)*1.E-6 -======= DO I = 1,IM IF(DUEM(I,J,1)>>>>>> upstream/develop DO K=2,NBIN_DU IF(DUEM(I,J,K)>>>>>> upstream/develop DO K=2,NBIN_DU IF(DUSD(I,J,K)0) THEN ! DO J = JSTA,JEND -! DO I = ista,iend +! DO I = 1,IM ! 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 @@ -5267,7 +5201,7 @@ SUBROUTINE CLDRAD ! ID(1:25) = 0 ! ID(02)=141 ! if(grib=='grib1') then -! CALL GRIBIT(IGET(661),LVLS(1,IGET(661)),GRIDista,iend,JM) +! CALL GRIBIT(IGET(661),LVLS(1,IGET(661)),GRID1,IM,JM) ! elseif(grib=='grib2') then ! cfld=cfld+1 ! fld_info(cfld)%ifld=IAVBLFLD(IGET(661)) @@ -5279,7 +5213,7 @@ SUBROUTINE CLDRAD IF (IGET(686)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend + DO I = 1,IM !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = DUSTPM(I,J) !ug/m3 END DO @@ -5294,7 +5228,7 @@ SUBROUTINE CLDRAD !! ADD DUST WET DEPOSITION FLUXES (kg/m2/sec) ! IF (IGET(662)>0) THEN ! DO J = JSTA,JEND -! DO I = ista,iend +! DO I = 1,IM ! 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 @@ -5304,7 +5238,7 @@ SUBROUTINE CLDRAD ! ID(1:25) = 0 ! ID(02)=141 ! if(grib=='grib1') then -! CALL GRIBIT(IGET(662),LVLS(1,IGET(662)),GRIDista,iend,JM) +! CALL GRIBIT(IGET(662),LVLS(1,IGET(662)),GRID1,IM,JM) ! elseif(grib=='grib2') then ! cfld=cfld+1 ! fld_info(cfld)%ifld=IAVBLFLD(IGET(662)) @@ -5316,7 +5250,7 @@ SUBROUTINE CLDRAD IF (IGET(684)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend + DO I = 1,IM !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = SSPM(I,J) !ug/m3 END DO @@ -5331,7 +5265,7 @@ SUBROUTINE CLDRAD IF (IGET(619)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend + DO I = 1,IM !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = DUSMASS(I,J) !ug/m3 END DO @@ -5347,7 +5281,7 @@ SUBROUTINE CLDRAD IF (IGET(620)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend + DO I = 1,IM !GRID1(I,J) = DUSMASS25(I,J) * 1.E-6 GRID1(I,J) = DUSMASS25(I,J) ! ug/m3 END DO @@ -5363,7 +5297,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend + DO I = 1,IM !GRID1(I,J) = DUCMASS(I,J) * 1.E-6 IF(DUCMASS(I,J)>>>>>> upstream/develop END DO END DO if(grib=='grib2') then @@ -5418,13 +5347,8 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND -<<<<<<< HEAD - DO I = ista,iend - GRID1(I,J) = SSCB(I,J) * 1.E-9 -======= DO I = 1,IM IF(SSCB(I,J)>>>>>> upstream/develop END DO END DO if(grib=='grib2') then @@ -5438,13 +5362,8 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND -<<<<<<< HEAD - DO I = ista,iend - GRID1(I,J) = BCCB(I,J) * 1.E-9 -======= DO I = 1,IM IF(BCCB(I,J)>>>>>> upstream/develop END DO END DO if(grib=='grib2') then @@ -5459,13 +5378,8 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND -<<<<<<< HEAD - DO I = ista,iend - GRID1(I,J) = OCCB(I,J) * 1.E-9 -======= DO I = 1,IM IF(OCCB(I,J)>>>>>> upstream/develop END DO END DO if(grib=='grib2') then @@ -5480,13 +5394,8 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND -<<<<<<< HEAD - DO I = ista,iend - GRID1(I,J) = SULFCB(I,J) * 1.E-9 -======= DO I = 1,IM IF(SULFCB(I,J)>>>>>> upstream/develop END DO END DO if(grib=='grib2') then @@ -5543,7 +5452,7 @@ SUBROUTINE CLDRAD ! CB cover is derived from CPRAT (same as #272 in SURFCE.f) EGRID1 = SPVAL DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(AVGCPRATE(I,J) /= SPVAL) then EGRID1(I,J) = AVGCPRATE(I,J)*(1000./DTQ2) end if @@ -5557,7 +5466,7 @@ SUBROUTINE CLDRAD EGRID3 = SPVAL IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') then DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EGRID2(I,J) = PBOT(I,J) EGRID3(I,J) = PTOP(I,J) END DO @@ -5566,7 +5475,7 @@ SUBROUTINE CLDRAD ! Derive CB base and top, relationship among CB fields DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(EGRID1(I,J)<= 0. .or. EGRID2(I,J)<= 0. .or. EGRID3(I,J) <= 0.) then EGRID1(I,J) = SPVAL EGRID2(I,J) = SPVAL @@ -5575,7 +5484,7 @@ SUBROUTINE CLDRAD END DO END DO DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(EGRID2(I,J) == SPVAL .or. EGRID3(I,J) == SPVAL) cycle if(EGRID3(I,J) < 400.*100. .and. & (EGRID2(I,J)-EGRID3(I,J)) > 300.*100) then @@ -5624,7 +5533,7 @@ SUBROUTINE CLDRAD IF(IGET(473) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -5633,7 +5542,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5642,7 +5551,7 @@ SUBROUTINE CLDRAD IF(IGET(474) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = EGRID2(I,J) ENDDO ENDDO @@ -5651,7 +5560,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5660,7 +5569,7 @@ SUBROUTINE CLDRAD IF(IGET(475) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -5669,7 +5578,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5686,7 +5595,7 @@ 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,ista,iend + use ctlblk_mod, only: SPVAL,JSTA,JEND,IM implicit none real, intent(inout) :: cbcov(IM,JSTA:JEND) @@ -5739,7 +5648,7 @@ 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,ista,iend + cfld, datapd, fld_info, jsta_2l, jend_2u use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD implicit none ! @@ -5752,13 +5661,8 @@ subroutine wrt_aero_diag(igetfld,nbin,data) GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND -<<<<<<< HEAD - DO I = ista,iend - grid1(I,J) = data(I,J,1) -======= DO I = 1,IM if(data(I,J,1)>>>>>> upstream/develop DO K=2,NBIN if(data(I,J,K)>>>>>> upstream/develop logical :: SIGMA,RUN,FIRST,RESTRT logical :: global logical :: SMFLAG @@ -76,6 +72,7 @@ module CTLBLK_mod CLDRAD_tim=0.,MISCLN_tim=0.,FIXED_tim=0., & MDL2SIGMA_tim=0.,READxml_tim=0.,MDL2AGL_tim=0., & MDL2STD_tim=0.,MDL2THANDPV_tim=0.,CALRAD_WCLOUD_tim=0.!comm tim_info + ! real(kind=8) :: time_output=0., time_e2out=0. !comm jjt ! diff --git a/sorc/ncep_post.fd/grib2_module.f b/sorc/ncep_post.fd/grib2_module.f index b3cec8c64..b944d84d8 100644 --- a/sorc/ncep_post.fd/grib2_module.f +++ b/sorc/ncep_post.fd/grib2_module.f @@ -208,7 +208,6 @@ subroutine gribit2(post_fname) character(255),intent(in) :: post_fname ! !------- local variables - real*8 timef,ta,tb,tc,td,te,tf,tg,th integer i,j,k,n,nm,nprm,nlvl,fldlvl1,fldlvl2,cstart,cgrblen,ierr integer nf,nfpe,nmod integer fh, clength,lunout @@ -355,11 +354,8 @@ subroutine gribit2(post_fname) allocate(datafldtmp(im_jm*nfld_pe(me+1)) ) allocate(datafld(im_jm,nfld_pe(me+1)) ) ! - ta=timef() call mpi_alltoallv(datapd,iscnt,isdsp,MPI_REAL, & datafldtmp,ircnt,irdsp,MPI_REAL,MPI_COMM_COMP,ierr) - tb=timef() - if(me .eq. 0) print *,' GWVX GRIBIT2 alltoall ',tb-ta ! !--- re-arrange the data datafld=0. @@ -413,12 +409,8 @@ subroutine gribit2(post_fname) ! !--- generate grib2 message --- ! - ta=timef() call gengrb2msg(idisc,icatg, iparm,nprm,nlvl,fldlvl1,fldlvl2,ntrange, & leng_time_range_stat,datafld(:,i),cgrib(cstart),clength) - tb=timef() - if(me .eq. 0) print 301,' GWVX GRIB2 WRITE ',tb-ta,timef() - 301 format(a25,2f10.3) cstart=cstart+clength ! else From e03f8ac7cd7fb9e94c931ff4dfea2d2cc6faa1a2 Mon Sep 17 00:00:00 2001 From: wx15gv Date: Tue, 4 May 2021 13:31:43 +0000 Subject: [PATCH 07/77] repair of a bunch of changed routines somehow corrupted by a merge 5/3/2021 --- sorc/ncep_post.fd/CLDRAD.f | 644 +++++++++-------------- sorc/ncep_post.fd/CTLBLK.f | 4 +- sorc/ncep_post.fd/MDL2AGL.f | 17 - sorc/ncep_post.fd/MDL2P.f | 113 +--- sorc/ncep_post.fd/MDL2SIGMA.f | 7 +- sorc/ncep_post.fd/MDL2SIGMA2.f | 6 - sorc/ncep_post.fd/MDLFLD.f | 296 +---------- sorc/ncep_post.fd/MISCLN.f | 867 +------------------------------ sorc/ncep_post.fd/PROCESS.f | 7 - sorc/ncep_post.fd/SURFCE.f | 192 +------ sorc/ncep_post.fd/TIMEF.f | 11 - sorc/ncep_post.fd/WRFPOST.f | 61 +-- sorc/ncep_post.fd/grib2_module.f | 8 + 13 files changed, 328 insertions(+), 1905 deletions(-) diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index 749e4f3bf..a8b54386d 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -70,9 +70,6 @@ !! 20-03-25 Jesse Meng - remove grib1 !! 20-05-20 Jesse Meng - CALRH unification with NAM scheme !! 20-11-10 Jesse Meng - USE UPP_PHYSICS MODULE -!! 21-02-08 Anning Cheng, read aod550, aod550_du/su/ss/oc/bc -!! directly from fv3gfs and output to grib2 by setting rdaod -!! 21-04-01 Jesse Meng - COMPUTATION ON DEFINED POINTS ONLY !! !! USAGE: CALL CLDRAD !! INPUT ARGUMENT LIST: @@ -117,8 +114,7 @@ SUBROUTINE CLDRAD SWDDIFC, SWUPBC, LWDNBC, LWUPBC, SWUPT, & TAOD5502D, AERSSA2D, AERASY2D, MEAN_FRP, LWP, IWP, & AVGCPRATE, & - DUSTCB,SSCB,BCCB,OCCB,SULFCB,DUSTPM,SSPM,aod550, & - du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550 + DUSTCB,SSCB,BCCB,OCCB,SULFCB,DUSTPM,SSPM use masks, only: LMH, HTM use params_mod, only: TFRZ, D00, H99999, QCLDMIN, SMALL, D608, H1, ROG, & GI, RD, QCONV, ABSCOEFI, ABSCOEF, STBOL, PQ0, A2, & @@ -127,7 +123,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,ista,iend use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD use gridspec_mod, only: dyval, gridtype use cmassi_mod, only: TRAD_ice @@ -144,10 +140,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, & @@ -160,11 +156,9 @@ SUBROUTINE CLDRAD real :: ceiling_thresh_cldfra, cldfra_max, & zceil, zceil1, zceil2, previous_sum, & ceil_min, ceil_neighbor - 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, & @@ -174,8 +168,8 @@ SUBROUTINE CLDRAD ! real FULL_CLD(IM,JM) !-- Must be dimensioned for the full domain ! - real dummy(IM,jsta:jend) - integer idummy(IM,jsta:jend) + real dummy(ista:iend,jsta:jend) + integer idummy(ista:iend,jsta:jend) ! ! --- Revision added for GOCART --- @@ -220,7 +214,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(:,:,:) @@ -228,10 +222,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 @@ -252,7 +246,6 @@ SUBROUTINE CLDRAD ! INDEX FOR TOTAL AND SPECIATED AEROSOLS (DU, SS, SU, OC, BC) data INDX_EXT / 610, 611, 612, 613, 614 / data INDX_SCA / 651, 652, 653, 654, 655 / - logical, parameter :: debugprint = .false. ! ! !************************************************************************* @@ -271,7 +264,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 @@ -281,14 +274,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 @@ -301,7 +294,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -316,7 +309,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend if (grid1(i,jj) /= spval) grid1(i,jj) = grid1(i,jj) - tfrz datapd(i,j,cfld) = GRID1(i,jj) enddo @@ -342,7 +335,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 @@ -353,7 +346,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -370,7 +363,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 @@ -384,7 +377,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 @@ -392,7 +385,7 @@ 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 @@ -402,7 +395,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -418,7 +411,7 @@ SUBROUTINE CLDRAD GRID1 = spval CALL CALPW(GRID1(1,jsta),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 @@ -429,7 +422,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -448,7 +441,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -467,7 +460,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -476,12 +469,10 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN CLOUD WATER IF (IGET(200) > 0 .or. IGET(575) > 0) THEN - GRID1 = spval - GRID2 = spval IF (MODELNAME == 'RAPR') THEN DO J=JSTA,JEND - DO I=1,IM - IF(LWP(I,J) < SPVAL) GRID1(I,J) = LWP(I,J)/1000.0 ! use WRF-diagnosed value + DO I=ista,iend + GRID1(I,J) = LWP(I,J)/1000.0 ! use WRF-diagnosed value ENDDO ENDDO ELSE @@ -491,12 +482,8 @@ SUBROUTINE CLDRAD CALL CALPW(GRID2(1,jsta),3) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM - IF(GRID1(I,J) 0) THEN - GRID1 = spval IF (MODELNAME == 'RAPR') THEN DO J=JSTA,JEND - DO I=1,IM - IF(IWP(I,J) < SPVAL) GRID1(I,J) = IWP(I,J)/1000.0 ! use WRF-diagnosed value + DO I=ista,iend + GRID1(I,J) = IWP(I,J)/1000.0 ! use WRF-diagnosed value ENDDO ENDDO ELSE @@ -551,7 +537,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -568,7 +554,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -585,7 +571,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -603,7 +589,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -621,7 +607,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -638,7 +624,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -655,7 +641,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -671,7 +657,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -687,7 +673,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -704,8 +690,8 @@ SUBROUTINE CLDRAD ENDIF !$omp parallel do DO J=JSTA,JEND - DO I=1,IM - IF(GRID1(I,J) < SPVAL) GRID1(I,J) = GRID1(I,J)*RRNUM + DO I=ista,iend + GRID1(I,J) = GRID1(I,J)*RRNUM ENDDO ENDDO ID(1:25)=0 @@ -737,7 +723,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -754,8 +740,8 @@ SUBROUTINE CLDRAD ENDIF !$omp parallel do DO J=JSTA,JEND - DO I=1,IM - IF(GRID1(I,J) < SPVAL) GRID1(I,J) = GRID1(I,J)*RRNUM + DO I=ista,iend + GRID1(I,J) = GRID1(I,J)*RRNUM ENDDO ENDDO ID(1:25)=0 @@ -787,7 +773,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -823,7 +809,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -833,7 +819,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 @@ -873,7 +859,7 @@ SUBROUTINE CLDRAD 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 @@ -883,7 +869,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -896,7 +882,7 @@ 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 @@ -915,7 +901,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. @@ -935,7 +921,7 @@ SUBROUTINE CLDRAD ! 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 @@ -1020,7 +1006,7 @@ SUBROUTINE CLDRAD IF (IGET(799)>0) THEN !$omp parallel do private(i,j) 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 @@ -1040,7 +1026,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 @@ -1054,7 +1040,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1065,7 +1051,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 @@ -1104,7 +1090,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1116,7 +1102,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 @@ -1130,7 +1116,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1141,7 +1127,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 @@ -1180,7 +1166,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1192,7 +1178,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 @@ -1206,7 +1192,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1218,7 +1204,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 @@ -1257,7 +1243,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1270,7 +1256,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 @@ -1282,7 +1268,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))* & @@ -1294,7 +1280,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 @@ -1308,7 +1294,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1319,10 +1305,10 @@ SUBROUTINE CLDRAD ! TIME AVERAGED TOTAL CLOUD FRACTION. IF (IGET(144) > 0) THEN ! GRID1=SPVAL - IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R')THEN + IF(MODELNAME == 'GFS')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 @@ -1333,7 +1319,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 @@ -1342,19 +1328,14 @@ SUBROUTINE CLDRAD ! ENDIF !ADDED BRAD'S MODIFICATION RSUM = D00 - IF (NCFRST(I,J) 0) RSUM=ACFRST(I,J)/NCFRST(I,J) IF (NCFRCV(I,J) > 0) & RSUM=MAX(RSUM, ACFRCV(I,J)/NCFRCV(I,J)) GRID1(I,J) = RSUM*100. - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO END IF - IF(MODELNAME == 'NMM' .OR. MODELNAME == 'GFS' .OR. & - MODELNAME == 'FV3R')THEN + IF(MODELNAME == 'NMM' .OR. MODELNAME == 'GFS')THEN ID(1:25)= 0 ITCLOD = NINT(TCLOD) IF(ITCLOD /= 0) then @@ -1387,7 +1368,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1400,20 +1381,16 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=1,IM - IF (NCFRST(I,J)0.0) THEN GRID1(I,J) = ACFRST(I,J)/NCFRST(I,J)*100. ELSE GRID1(I,J) = D00 ENDIF - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO END IF - IF(MODELNAME=='NMM' .or. MODELNAME=='FV3R')THEN + IF(MODELNAME=='NMM')THEN ID(1:25)=0 ITCLOD = NINT(TCLOD) IF(ITCLOD /= 0) then @@ -1452,16 +1429,12 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=1,IM - IF (NCFRCV(I,J)0.0) THEN GRID1(I,J) = ACFRCV(I,J)/NCFRCV(I,J)*100. ELSE GRID1(I,J) = D00 ENDIF - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO END IF @@ -1512,7 +1485,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 ! @@ -1643,7 +1616,7 @@ 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 @@ -1662,7 +1635,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 @@ -1693,7 +1666,7 @@ 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 @@ -1707,7 +1680,7 @@ SUBROUTINE CLDRAD 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 @@ -1746,7 +1719,7 @@ SUBROUTINE CLDRAD DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend ! !- imported from RUC post IF(MODELNAME == 'RAPR') then @@ -1938,7 +1911,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 @@ -1947,9 +1920,9 @@ SUBROUTINE CLDRAD ! GSD CLOUD BOTTOM HEIGHTS IF (IGET(408)>0) THEN -!!$omp parallel do private(i,j) +!$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 @@ -1973,7 +1946,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. @@ -2044,7 +2017,7 @@ SUBROUTINE CLDRAD ! proceed to gridding DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = ceil(I,J) ENDDO ENDDO @@ -2074,7 +2047,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 @@ -2192,7 +2165,7 @@ SUBROUTINE CLDRAD ! layer. 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(JSTA,J-numr),min(JEND,J+numr) do ic = max(1,I-numr),min(IM,I+numr) @@ -2203,7 +2176,7 @@ SUBROUTINE CLDRAD CLDZ(I,J) = ceil_min + FIS(I,J)*GI ! convert back to ASL and store CLDZ(I,J) = max(min(CLDZ(I,J), 20000.0),0.0) !set bounds ! find pressure at CLDZ - do k=2,lm-2 + do k=1,lm-2 if ( zmid(i,j,lm-k+1) >= CLDZ(i,j) ) then CLDP(I,J) = pmid(i,j,lm-k+2) + (CLDZ(i,j)-zmid(i,j,lm-k+2)) & *(pmid(i,j,lm-k+1)-pmid(i,j,lm-k+2) ) & @@ -2216,9 +2189,9 @@ SUBROUTINE CLDRAD ! GSD CLOUD BOTTOM HEIGHT IF (IGET(711)>0) THEN -!!$omp parallel do private(i,j) +!$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 @@ -2231,9 +2204,9 @@ SUBROUTINE CLDRAD ! GSD CLOUD BOTTOM PRESSURE IF (IGET(798)>0) THEN -!!$omp parallel do private(i,j) +!$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 @@ -2251,7 +2224,7 @@ 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 @@ -2265,7 +2238,7 @@ SUBROUTINE CLDRAD 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 @@ -2275,7 +2248,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2288,13 +2261,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) @@ -2310,7 +2283,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2321,7 +2294,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) @@ -2340,7 +2313,7 @@ SUBROUTINE CLDRAD ! 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) @@ -2359,7 +2332,7 @@ SUBROUTINE CLDRAD ! 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) @@ -2379,7 +2352,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 @@ -2422,7 +2395,7 @@ SUBROUTINE CLDRAD ! 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 @@ -2465,7 +2438,7 @@ SUBROUTINE CLDRAD ! 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 @@ -2514,7 +2487,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 @@ -2564,7 +2537,7 @@ SUBROUTINE CLDRAD ! 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 @@ -2582,7 +2555,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. @@ -2646,7 +2619,7 @@ 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 @@ -2660,7 +2633,7 @@ SUBROUTINE CLDRAD ! 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 @@ -2676,7 +2649,7 @@ 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 @@ -2692,7 +2665,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 @@ -2792,13 +2765,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) @@ -2814,7 +2787,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2825,7 +2798,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) @@ -2844,7 +2817,7 @@ SUBROUTINE CLDRAD ! 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) @@ -2864,7 +2837,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) @@ -2884,7 +2857,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 @@ -2927,7 +2900,7 @@ SUBROUTINE CLDRAD ! 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 @@ -2966,7 +2939,7 @@ SUBROUTINE CLDRAD ! 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 @@ -3006,7 +2979,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 @@ -3045,7 +3018,7 @@ SUBROUTINE CLDRAD ! 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 @@ -3084,7 +3057,7 @@ SUBROUTINE CLDRAD ! 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 @@ -3124,7 +3097,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 @@ -3148,7 +3121,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 @@ -3188,7 +3161,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 @@ -3240,7 +3213,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 @@ -3293,7 +3266,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 @@ -3347,7 +3320,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 @@ -3400,7 +3373,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 @@ -3452,7 +3425,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 @@ -3504,7 +3477,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 @@ -3556,7 +3529,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 @@ -3608,7 +3581,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 @@ -3654,7 +3627,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 @@ -3673,7 +3646,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 @@ -3688,17 +3661,14 @@ SUBROUTINE CLDRAD ! ! CURRENT INCOMING SW RADIATION AT THE SURFACE. IF (IGET(156)>0) THEN - GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM - IF(RSWIN(I,J)1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE FACTRS=0.0 ENDIF - IF(RSWIN(I,J)0.0) THEN LLMH=NINT(LMH(I,J)) TLMH=T(I,J,LLMH) @@ -3727,7 +3696,6 @@ SUBROUTINE CLDRAD FACTRL=0.0 ENDIF IF(RLWIN(I,J) < spval) GRID1(I,J)=RLWIN(I,J)*FACTRL - ENDIF ENDIF ENDDO ENDDO @@ -3741,18 +3709,15 @@ SUBROUTINE CLDRAD ! ! CURRENT OUTGOING SW RADIATION AT THE SURFACE. IF (IGET(141)>0) THEN - GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM - IF(RSWOUT(I,J)1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE FACTRS=0.0 ENDIF - IF(RSWOUT(I,J)0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = SWUPBC(I,J) ENDDO ENDDO @@ -3781,7 +3746,7 @@ 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 @@ -3795,7 +3760,7 @@ SUBROUTINE CLDRAD ! 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 @@ -3809,7 +3774,7 @@ SUBROUTINE CLDRAD ! 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 @@ -3822,14 +3787,14 @@ SUBROUTINE CLDRAD ! Instantaneous MEAN_FRP IF (IGET(740)>0) THEN -! print *,"GETTING INTO MEAN_FRP PART" + 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 if(grib=='grib2') then -! print *,"GETTING INTO MEAN_FRP GRIB2 PART" + 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) @@ -3838,18 +3803,15 @@ SUBROUTINE CLDRAD ! CURRENT (instantaneous) INCOMING CLEARSKY SW RADIATION AT THE SURFACE. IF (IGET(262)>0) THEN - GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM - IF(RSWINC(I,J)1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE FACTRS=0.0 ENDIF - IF(RSWINC(I,J)0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = SWDNBC(I,J) ENDDO ENDDO @@ -3877,7 +3839,7 @@ 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 @@ -3891,7 +3853,7 @@ SUBROUTINE CLDRAD ! 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 @@ -3906,7 +3868,7 @@ 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 @@ -3920,7 +3882,7 @@ SUBROUTINE CLDRAD ! 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 @@ -3934,7 +3896,7 @@ SUBROUTINE CLDRAD ! 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 @@ -3972,7 +3934,7 @@ SUBROUTINE CLDRAD ! 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 @@ -4010,7 +3972,7 @@ SUBROUTINE CLDRAD ! 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 @@ -4024,7 +3986,7 @@ SUBROUTINE CLDRAD ! 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 @@ -4062,7 +4024,7 @@ SUBROUTINE CLDRAD ! 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 @@ -4100,7 +4062,7 @@ SUBROUTINE CLDRAD ! 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 @@ -4138,7 +4100,7 @@ SUBROUTINE CLDRAD ! 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 @@ -4176,7 +4138,7 @@ SUBROUTINE CLDRAD ! 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 @@ -4214,7 +4176,7 @@ SUBROUTINE CLDRAD ! 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 @@ -4254,7 +4216,7 @@ SUBROUTINE CLDRAD ! 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 @@ -4293,7 +4255,7 @@ SUBROUTINE CLDRAD ! 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 @@ -4332,7 +4294,7 @@ SUBROUTINE CLDRAD ! 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 @@ -4368,92 +4330,10 @@ SUBROUTINE CLDRAD endif ENDIF - !2D AEROSOL OPTICAL DEPTH AT 550 NM - IF(rdaod) then - IF (IGET(609).GT.0) THEN - DO J=JSTA,JEND - DO I=1,IM - 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) - endif - ENDIF - - IF (IGET(610).GT.0) THEN - DO J=JSTA,JEND - DO I=1,IM - 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) - endif - ENDIF - - IF (IGET(611).GT.0) THEN - DO J=JSTA,JEND - DO I=1,IM - 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) - endif - ENDIF - - IF (IGET(612).GT.0) THEN - DO J=JSTA,JEND - DO I=1,IM - 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) - endif - ENDIF - - IF (IGET(613).GT.0) THEN - DO J=JSTA,JEND - DO I=1,IM - 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) - endif - ENDIF - - - IF (IGET(614).GT.0) THEN - DO J=JSTA,JEND - DO I=1,IM - 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) - endif - ENDIF - END IF !rdaod - !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 @@ -4467,7 +4347,7 @@ SUBROUTINE CLDRAD !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 @@ -4481,7 +4361,7 @@ SUBROUTINE CLDRAD !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 @@ -4522,10 +4402,6 @@ SUBROUTINE CLDRAD DO I = 690, 698 ! TOTAL AND SPECIATED AEROSOL IF ( IGET(I)>0 ) LAERSMASS = .TRUE. ENDDO - IF ( rdaod ) THEN - LAEROPT = .FALSE. - LAERSMASS = .FALSE. - END IF IF ( LAEROPT ) THEN PRINT *, 'COMPUTE AEROSOL OPTICAL PROPERTIES' @@ -4567,7 +4443,7 @@ SUBROUTINE CLDRAD print *,' ERROR! Non-zero iostat for rd_LUTS ', aerosol_file stop ENDIF - if(debugprint)print *,'i=',i,'read aerosol_file=',trim(aerosol_file),'ios=',ios + print *,'i=',i,'read aerosol_file=',trim(aerosol_file),'ios=',ios ! IF (AerosolName(i) == 'DUST') nbin = nbin_du IF (AerosolName(i) == 'SALT') nbin = nbin_ss @@ -4669,19 +4545,19 @@ SUBROUTINE CLDRAD ENDDO ! j-loop for nbin ENDDO ! i-loop for nAero -! print *,'finish reading coef' + print *,'finish reading coef' 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 (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) @@ -4689,7 +4565,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) @@ -4766,7 +4642,7 @@ SUBROUTINE CLDRAD IF ( IB == 2 ) LEXT = .TRUE. IF ( IB == 5 ) LEXT = .TRUE. ENDIF -! print *,'LEXT=',LEXT,'LSCA=',LSCA,'LASY=',LASY + print *,'LEXT=',LEXT,'LSCA=',LSCA,'LASY=',LASY ! SKIP IF POST PRODUCT IS NOT REQUESTED IF ( LEXT .OR. LSCA .OR. LASY ) THEN ! COMPUTE DUST AOD @@ -4777,7 +4653,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) @@ -4804,7 +4680,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 @@ -4838,7 +4714,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 @@ -4871,7 +4747,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 @@ -4903,7 +4779,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 @@ -4933,7 +4809,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) @@ -4965,7 +4841,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 @@ -4974,7 +4850,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 @@ -4985,7 +4861,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 @@ -5002,18 +4878,15 @@ SUBROUTINE CLDRAD ! AER ASYM FACTOR AT 340 NM IF ( IGET(649) > 0 ) THEN - GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM - IF(SCA2D(I,J) 0.0 ) THEN ASY2D(I,J) = ASY2D(I,J) / SCA2D(I,J) ELSE ASY2D(I,J) = 0. ENDIF - IF(ASY2D(I,J) 0 ) THEN - GRID1 = SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM - IF(AOD(I,J) 0.0 ) THEN SCA2D(I,J) = SCA2D(I,J) / AOD(I,J) ELSE SCA2D(I,J) = 1.0 ENDIF - IF(SCA2D(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)=SCA2D(I,J) ENDDO ENDDO @@ -5079,7 +4949,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) @@ -5100,7 +4970,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) @@ -5129,7 +4999,7 @@ SUBROUTINE CLDRAD ANG2 = LOG ( 860. / 440. ) !$omp parallel do private(i,j) 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 @@ -5137,7 +5007,7 @@ SUBROUTINE CLDRAD GRID1(I,J)=ANGST(I,J) ENDDO ENDDO - if(debugprint)print *,'output angstrom exp,angst=',maxval(angst(1:im,jsta:jend)), & + print *,'output angstrom exp,angst=',maxval(angst(1:im,jsta:jend)), & minval(angst(1:im,jsta:jend)) CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then @@ -5154,10 +5024,9 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM - 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 @@ -5201,7 +5069,7 @@ SUBROUTINE CLDRAD ! ID(1:25) = 0 ! ID(02)=141 ! if(grib=='grib1') then -! CALL GRIBIT(IGET(661),LVLS(1,IGET(661)),GRID1,IM,JM) +! CALL GRIBIT(IGET(661),LVLS(1,IGET(661)),GRIDista,iend,JM) ! elseif(grib=='grib2') then ! cfld=cfld+1 ! fld_info(cfld)%ifld=IAVBLFLD(IGET(661)) @@ -5213,7 +5081,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 @@ -5228,7 +5096,7 @@ SUBROUTINE CLDRAD !! 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 @@ -5238,7 +5106,7 @@ SUBROUTINE CLDRAD ! ID(1:25) = 0 ! ID(02)=141 ! if(grib=='grib1') then -! CALL GRIBIT(IGET(662),LVLS(1,IGET(662)),GRID1,IM,JM) +! CALL GRIBIT(IGET(662),LVLS(1,IGET(662)),GRIDista,iend,JM) ! elseif(grib=='grib2') then ! cfld=cfld+1 ! fld_info(cfld)%ifld=IAVBLFLD(IGET(662)) @@ -5250,7 +5118,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 @@ -5265,7 +5133,7 @@ SUBROUTINE CLDRAD 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 @@ -5281,7 +5149,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 @@ -5294,12 +5162,11 @@ SUBROUTINE CLDRAD ENDIF !! ADD TOTAL AEROSOL PM10 COLUMN DENSITY (kg/m2) ! IF (IGET(621)>0 ) THEN - GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = ista,iend !GRID1(I,J) = DUCMASS(I,J) * 1.E-6 - IF(DUCMASS(I,J)0 ) THEN - GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = ista,iend !GRID1(I,J) = DUCMASS25(I,J) * 1.E-6 - IF(DUCMASS25(I,J)0 ) THEN - GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM - IF(DUSTCB(I,J)0 ) THEN - GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM - IF(SSCB(I,J)0 ) THEN - GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM - IF(BCCB(I,J)0 ) THEN - GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM - IF(OCCB(I,J)0 ) THEN - GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM - IF(SULFCB(I,J)0) call wrt_aero_diag(659,nbin_du,duem) -! print *,'aft wrt disg duem' + print *,'aft wrt disg duem' IF (IGET(660)>0) call wrt_aero_diag(660,nbin_du,dusd) IF (IGET(661)>0) call wrt_aero_diag(661,nbin_du,dudp) IF (IGET(662)>0) call wrt_aero_diag(662,nbin_du,duwt) IF (IGET(679)>0) call wrt_aero_diag(679,nbin_du,dusv) -! print *,'aft wrt disg duwt' + print *,'aft wrt disg duwt' !! wrt SS diag field IF (IGET(663)>0) call wrt_aero_diag(663,nbin_ss,ssem) @@ -5421,7 +5282,7 @@ SUBROUTINE CLDRAD IF (IGET(665)>0) call wrt_aero_diag(665,nbin_ss,ssdp) IF (IGET(666)>0) call wrt_aero_diag(666,nbin_ss,sswt) IF (IGET(680)>0) call wrt_aero_diag(680,nbin_ss,sssv) -! print *,'aft wrt disg sswt' + print *,'aft wrt disg sswt' !! wrt BC diag field IF (IGET(667)>0) call wrt_aero_diag(667,nbin_bc,bcem) @@ -5429,7 +5290,7 @@ SUBROUTINE CLDRAD IF (IGET(669)>0) call wrt_aero_diag(669,nbin_bc,bcdp) IF (IGET(670)>0) call wrt_aero_diag(670,nbin_bc,bcwt) IF (IGET(681)>0) call wrt_aero_diag(681,nbin_bc,bcsv) -! print *,'aft wrt disg bcwt' + print *,'aft wrt disg bcwt' !! wrt OC diag field IF (IGET(671)>0) call wrt_aero_diag(671,nbin_oc,ocem) @@ -5437,7 +5298,7 @@ SUBROUTINE CLDRAD IF (IGET(673)>0) call wrt_aero_diag(673,nbin_oc,ocdp) IF (IGET(674)>0) call wrt_aero_diag(674,nbin_oc,ocwt) IF (IGET(682)>0) call wrt_aero_diag(682,nbin_oc,ocsv) -! print *,'aft wrt disg ocwt' + print *,'aft wrt disg ocwt' !! wrt SU diag field ! IF (IGET(675)>0) call wrt_aero_diag(675,nbin_su,suem) @@ -5452,7 +5313,7 @@ SUBROUTINE CLDRAD ! CB cover is derived from CPRAT (same as #272 in SURFCE.f) EGRID1 = SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend if(AVGCPRATE(I,J) /= SPVAL) then EGRID1(I,J) = AVGCPRATE(I,J)*(1000./DTQ2) end if @@ -5466,7 +5327,7 @@ SUBROUTINE CLDRAD EGRID3 = SPVAL IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') then DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend EGRID2(I,J) = PBOT(I,J) EGRID3(I,J) = PTOP(I,J) END DO @@ -5475,7 +5336,7 @@ SUBROUTINE CLDRAD ! Derive CB base and top, relationship among CB fields DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend if(EGRID1(I,J)<= 0. .or. EGRID2(I,J)<= 0. .or. EGRID3(I,J) <= 0.) then EGRID1(I,J) = SPVAL EGRID2(I,J) = SPVAL @@ -5484,7 +5345,7 @@ SUBROUTINE CLDRAD END DO END DO DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(EGRID2(I,J) == SPVAL .or. EGRID3(I,J) == SPVAL) cycle if(EGRID3(I,J) < 400.*100. .and. & (EGRID2(I,J)-EGRID3(I,J)) > 300.*100) then @@ -5533,7 +5394,7 @@ 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 @@ -5542,7 +5403,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5551,7 +5412,7 @@ 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 @@ -5560,7 +5421,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5569,7 +5430,7 @@ 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 @@ -5578,7 +5439,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=ista,iend datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5595,7 +5456,7 @@ 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) @@ -5648,7 +5509,7 @@ 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,iend use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD implicit none ! @@ -5661,10 +5522,9 @@ subroutine wrt_aero_diag(igetfld,nbin,data) GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM - if(data(I,J,1)>>>>>> upstream/develop !! !! USAGE: CALL MDL2P !! INPUT ARGUMENT LIST: @@ -80,11 +76,7 @@ SUBROUTINE MDL2AGL ! LOGICAL IOOMG,IOALL REAL,dimension(im,jsta_2l:jend_2u) :: grid1 -<<<<<<< HEAD REAL,dimension(ista:iend,jsta_2l:jend_2u) :: UAGL, VAGL, tagl, pagl, qagl -======= - REAL,dimension(im,jsta_2l:jend_2u) :: UAGL, VAGL, tagl, pagl, qagl ->>>>>>> upstream/develop ! INTEGER,dimension(ista:iend,jsta_2l:jend_2u) :: NL1X integer,dimension(jm) :: IHE, IHW @@ -1298,20 +1290,11 @@ SUBROUTINE MDL2AGL !--- Wind Energy Potential -- 0.5 * moist air density * wind speed^3 IF((IGET(411)>0) ) THEN DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(QAGL(I,J)>>>>>> upstream/develop QAGL(I,J)=QAGL(I,J)/1000.0 PV=QAGL(I,J)*PAGL(I,J)/(EPS*(1-QAGL(I,J)) + QAGL(I,J)) RHO=(1/TAGL(I,J))*(((PAGL(I,J)-PV)/RD) + PV/461.495) GRID1(I,J)=0.5*RHO*(SQRT(UAGL(I,J)**2+VAGL(I,J)**2))**3 - ELSE - GRID1(I,J)=SPVAL - ENDIF ENDDO ENDDO if(grib=="grib2" )then diff --git a/sorc/ncep_post.fd/MDL2P.f b/sorc/ncep_post.fd/MDL2P.f index 17b9e8586..03f67acbd 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -28,8 +28,6 @@ !! 20-03-25 J MENG - remove grib1 !! 20-05-20 J MENG - CALRH unification with NAM scheme !! 20-11-10 J MENG - USE UPP_PHYSICS MODULE -!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) -!! 21-04-01 J MENG - COMPUTATION ON DEFINED POINTS ONLY !! !! USAGE: CALL MDL2P !! INPUT ARGUMENT LIST: @@ -73,8 +71,7 @@ SUBROUTINE MDL2P(iostatusD3D) CNVCTUMMIXING, NCNVCTCFRAC, CNVCTUMFLX, CNVCTDETMFLX, & CNVCTZGDRAG, CNVCTMGDRAG, ZMID, ZINT, PMIDV, & CNVCTDMFLX - use vrbls2d, only: T500,T700,W_UP_MAX,W_DN_MAX,W_MEAN,PSLP,FIS,Z1000,Z700,& - Z500 + use vrbls2d, only: T500, W_UP_MAX, W_DN_MAX, W_MEAN, PSLP, FIS, Z1000 use masks, only: LMH, SM use physcons_post,only: CON_FVIRT, CON_ROG, CON_EPS, CON_EPSM1 use params_mod, only: H1M12, DBZMIN, H1, PQ0, A2, A3, A4, RHMIN, G, & @@ -336,8 +333,8 @@ SUBROUTINE MDL2P(iostatusD3D) IF(Q(I,J,1) < SPVAL) QSL(I,J) = Q(I,J,1) IF(gridtype == 'A')THEN - IF(UH(I,J,1) < SPVAL) USL(I,J) = UH(I,J,1) - IF(VH(I,J,1) < SPVAL) VSL(I,J) = VH(I,J,1) + USL(I,J) = UH(I,J,1) + VSL(I,J) = VH(I,J,1) END IF ! if ( J == JSTA.and. I == 1.and.me == 0) & @@ -1018,24 +1015,9 @@ SUBROUTINE MDL2P(iostatusD3D) DO J=JSTA,JEND DO I=ista,iend T500(I,J) = TSL(I,J) - Z500(I,J) = FSL(I,J)*GI ENDDO ENDDO ENDIF - -! -!*** SAVE 700MB TEMPERATURE FOR LIFTED INDEX. -! - IF(NINT(SPL(LP)) == 70000)THEN -!$omp parallel do private(i,j) - DO J=JSTA,JEND - DO I=1,IM - T700(I,J) = TSL(I,J) - Z700(I,J) = FSL(I,J)*GI - ENDDO - ENDDO - ENDIF - ! !--------------------------------------------------------------------- !*** CALCULATE 1000MB GEOPOTENTIALS CONSISTENT WITH SLP OBTAINED @@ -1122,7 +1104,7 @@ SUBROUTINE MDL2P(iostatusD3D) if(grib == 'grib2')then dxm=dxm/1000.0 endif -! print *,'dxm=',dxm + print *,'dxm=',dxm NSMOOTH = nint(5.*(13500./dxm)) call AllGETHERV(GRID1) do k=1,NSMOOTH @@ -1186,16 +1168,8 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(910))>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(TSL(I,J) < SPVAL .AND. QSL(I,J) < SPVAL) THEN ->>>>>>> upstream/develop GRID1(I,J) = TSL(I,J)*(1.+0.608*QSL(I,J)) - ELSE - GRID1(I,J) = SPVAL - ENDIF ENDDO ENDDO @@ -1339,12 +1313,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(331)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - GRID1(I,J) = SPVAL ->>>>>>> upstream/develop CFRSL(I,J) = MIN(MAX(0.0,CFRSL(I,J)),1.0) IF(abs(CFRSL(I,J)-SPVAL) > SMALL) & GRID1(I,J) = CFRSL(I,J)*H100 @@ -1637,14 +1606,8 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(086)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(FSL(I,J)>>>>>> upstream/develop EGRID2(I,J) = FSL(I,J)*GI - ENDIF ENDDO ENDDO CALL CALSTRM(EGRID2(1,jsta),EGRID1(1,jsta)) @@ -1706,17 +1669,9 @@ 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 -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(QW1(I,J) < SPVAL .AND. QI1(I,J) < SPVAL) THEN ->>>>>>> upstream/develop GRID1(I,J) = QW1(I,J) + QI1(I,J) QI1(I,J) = spval - ELSE - GRID1(I,J) = SPVAL - ENDIF ENDDO ENDDO ELSE @@ -1970,16 +1925,8 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(258)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(FSL(I,J)>>>>>> upstream/develop GRID1(I,J) = FSL(I,J)*GI - ELSE - GRID1(I,J) = SPVAL - ENDIF EGRID1(I,J) = SPVAL ENDDO ENDDO @@ -2016,11 +1963,7 @@ SUBROUTINE MDL2P(iostatusD3D) DO I=ista,iend 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 -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(SMOKESL(I,J,1)>>>>>> upstream/develop GRID1(I,J) = (1./RD)*SMOKESL(I,J,1)*(SPL(LP)/TSL(I,J)) - ELSE - GRID1(I,J) = SPVAL - ENDIF ENDDO ENDDO if(grib == 'grib2')then @@ -3577,15 +3512,7 @@ SUBROUTINE MDL2P(iostatusD3D) ELSE IMOIS = 3 END IF -<<<<<<< HEAD HAINES(I,J) = ISTAA + IMOIS -======= - IF(TSL(I,J)>>>>>> upstream/develop ! if(i==570 .and. j==574)print*,'high hainesindex:',i,j,luhi,tsl(i,j) & ! ,tprs(i,j,luhi),tdsl(i,j),ista,imois,spl(luhi),spl(lp),haines(i,j) END IF @@ -3627,15 +3554,7 @@ SUBROUTINE MDL2P(iostatusD3D) END IF ! 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) -<<<<<<< HEAD HAINES(I,J) = ISTAA + IMOIS -======= - IF(TSL(I,J)>>>>>> upstream/develop END IF END DO END DO @@ -3674,17 +3593,8 @@ SUBROUTINE MDL2P(iostatusD3D) IMOIS = 3 END IF ! if(i==570 .and. j==574)print*,'low haines index:',i,j,luhi,tsl(i,j) & -<<<<<<< HEAD ! ,tprs(i,j,luhi),tdsl(i,j),istaa,imois,spl(luhi),spl(lp),haines(i,j) HAINES(I,J) = ISTAA + IMOIS -======= -! ,tprs(i,j,luhi),tdsl(i,j),ista,imois,spl(luhi),spl(lp),haines(i,j) - IF(TSL(I,J)>>>>>> upstream/develop END IF END DO END DO @@ -3830,8 +3740,8 @@ SUBROUTINE MDL2P(iostatusD3D) GRID1(I,J) = PSLP(I,J) ENDDO ENDDO -! print *,'inmdl2p,pslp=',maxval(pslp(1:im,jsta:jend)),minval(pslp(1:im,jsta:jend)) -! print *,'inmdl2p,point pslp=',pslp(im/2,(jsta+jend)/2),pslp(1,jsta),'cfld=',cfld + print *,'inmdl2p,pslp=',maxval(pslp(1:im,jsta:jend)),minval(pslp(1:im,jsta:jend)) + print *,'inmdl2p,point pslp=',pslp(im/2,(jsta+jend)/2),pslp(1,jsta),'cfld=',cfld if(grib == 'grib2')then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(023)) @@ -3883,16 +3793,8 @@ SUBROUTINE MDL2P(iostatusD3D) ! because MOS can't adjust to the much lower H !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(FSL(I,J)>>>>>> upstream/develop GRID1(I,J) = FSL(I,J)*GI - ELSE - GRID1(I,J) = SPVAL - ENDIF ENDDO ENDDO ELSE @@ -3943,9 +3845,6 @@ SUBROUTINE MDL2P(iostatusD3D) ENDIF ENDIF ! -if(allocated(d3dsl)) deallocate(d3dsl) -if(allocated(dustsl)) deallocate(dustsl) -if(allocated(smokesl)) deallocate(smokesl) ! END OF ROUTINE. ! RETURN diff --git a/sorc/ncep_post.fd/MDL2SIGMA.f b/sorc/ncep_post.fd/MDL2SIGMA.f index 0e541626a..6a29ac6b7 100644 --- a/sorc/ncep_post.fd/MDL2SIGMA.f +++ b/sorc/ncep_post.fd/MDL2SIGMA.f @@ -19,7 +19,6 @@ !! 04-11-24 H CHUANG - ADD FERRIER'S HYDROMETEOR FIELD !! 11-02064 J WANG - ADD GRIB2 option !! 20-03-25 J MENG - remove grib1 -!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) !! !! USAGE: CALL MDL2P !! INPUT ARGUMENT LIST: @@ -83,12 +82,10 @@ SUBROUTINE MDL2SIGMA ! real, dimension(im,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL, Q2SL, & real, dimension(ista:iend,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL, Q2SL, & FSL1, CFRSIG, EGRID1, EGRID2 - REAL GRID1(IM,JM) - real, dimension(im,jsta_2l:jend_2u) :: grid2 - + REAL GRID1(IM,JM),GRID2(IM,JM) REAL SIGO(LSIG+1),DSIGO(LSIG),ASIGO(LSIG) ! - INTEGER,dimension(im,jsta_2l:jend_2u) :: NL1X,NL1XF + INTEGER IHOLD(IM_JM),JHOLD(IM_JM),NL1X(IM,JM),NL1XF(IM,JM) ! ! !--- Definition of the following 2D (horizontal) dummy variables diff --git a/sorc/ncep_post.fd/MDL2SIGMA2.f b/sorc/ncep_post.fd/MDL2SIGMA2.f index 23e61fbc0..2529e9712 100644 --- a/sorc/ncep_post.fd/MDL2SIGMA2.f +++ b/sorc/ncep_post.fd/MDL2SIGMA2.f @@ -18,7 +18,6 @@ !! 02-07-29 H CHUANG - ADD UNDERGROUND FIELDS AND MEMBRANE SLP FOR WRF !! 04-11-24 H CHUANG - ADD FERRIER'S HYDROMETEOR FIELD !! 20-03-25 J MENG - remove grib1 -!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) !! !! USAGE: CALL MDL2P !! INPUT ARGUMENT LIST: @@ -60,13 +59,8 @@ SUBROUTINE MDL2SIGMA2 ! LOGICAL READTHK ! REAL,dimension(im,jm) :: FSL, TSL, QSL, osl, usl, vsl, q2sl, fsl1, & -<<<<<<< HEAD REAL,dimension(ista:iend,jsta_2l:jend_2u) :: TSL REAL,dimension(im,jm) :: grid1 -======= - REAL,dimension(im,jsta_2l:jend_2u) :: TSL - REAL,dimension(im,jsta_2l:jend_2u) :: grid1 ->>>>>>> upstream/develop REAL SIGO(LSIG+1),DSIGO(LSIG),ASIGO(LSIG) ! ! INTEGER,dimension(im,jm) :: IHOLD,JHOLD,NL1X,NL1XF diff --git a/sorc/ncep_post.fd/MDLFLD.f b/sorc/ncep_post.fd/MDLFLD.f index cbee0145d..11c6b5e07 100644 --- a/sorc/ncep_post.fd/MDLFLD.f +++ b/sorc/ncep_post.fd/MDLFLD.f @@ -42,7 +42,6 @@ !! 20-05-20 J MENG - CALRH unification with NAM scheme !! 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 !! !! USAGE: CALL MDLFLD !! INPUT ARGUMENT LIST: @@ -195,15 +194,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 -<<<<<<< HEAD ALLOCATE(EL (ista:iend,JSTA_2L:JEND_2U,LM)) ALLOCATE(RICHNO (ista:iend,JSTA_2L:JEND_2U,LM)) ALLOCATE(PBLRI (ista:iend,JSTA_2L:JEND_2U)) -======= - ALLOCATE(EL (IM,JSTA_2L:JEND_2U,LM)) - ALLOCATE(RICHNO (IM,JSTA_2L:JEND_2U,LM)) - ALLOCATE(PBLRI (IM,JSTA_2L:JEND_2U)) ->>>>>>> upstream/develop ! ! SECOND, STANDARD NGM SEA LEVEL PRESSURE. IF (IGET(105) > 0) THEN @@ -371,12 +364,7 @@ SUBROUTINE MDLFLD refl_miss: IF (Model_Radar) THEN ! - Model output DBZ is present - proceed with calc DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(P1D(I,J)>>>>>> upstream/develop ze_nc=10.**(0.1*REF_10CM(I,J,L)) DBZ1(I,J)=10.*LOG10(max(Zmin,(ze_nc+CUREFL(I,J)))) DBZR1(I,J)=MIN(DBZR1(I,J), REF_10CM(I,J,L)) @@ -410,10 +398,6 @@ SUBROUTINE MDLFLD DBZI1(I,J)=10.*LOG10(ze_s) ENDIF refl_adj ENDIF refl_comp - ELSE - DBZR1(I,J)=DBZmin - DBZI1(I,J)=DBZmin - ENDIF ENDDO ENDDO ELSE @@ -442,18 +426,9 @@ SUBROUTINE MDLFLD !--- This branch is executed if GFS micro (imp_physics=9) is run in the NMM. ! DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(C1D(I,J)>>>>>> upstream/develop QI1(I,J)=C1D(I,J)*FI1D(I,J) QW1(I,J)=C1D(I,J)-QI1(I,J) - ELSE - QI1(I,J)=D00 - QW1(I,J)=D00 - ENDIF QR1(I,J)=D00 QS1(I,J)=D00 DBZ1(I,J)=DBZmin @@ -564,6 +539,7 @@ SUBROUTINE MDLFLD DBZ(I,J,L)=MAX(DBZmin, DBZ(I,J,L)) DBZR(I,J,L)=MAX(DBZmin, DBZR(I,J,L)) DBZI(I,J,L)=MAX(DBZmin, DBZI(I,J,L)) + ENDIF !-- End IF (L > LMH(I,J)) ... ENDDO !-- End DO I loop ENDDO @@ -654,7 +630,6 @@ SUBROUTINE MDLFLD DBZC(I,J,L)=CUREFL(I,J) ENDIF !-- End IF (CUREFL_S(I,J) > 0.) - IF(T(I,J,L) 1.0E-3) & & DENS = PMID(I,J,L)/(RD*T(I,J,L)*(Q(I,J,L)*D608+1.0)) ! DENSITY @@ -720,12 +695,6 @@ SUBROUTINE MDLFLD DBZI(I,J,L) = MAX(DBZmin, DBZI(I,J,L)) DBZC(I,J,L) = MAX(DBZmin, DBZC(I,J,L)) END IF - ELSE - DBZ(I,J,L) = DBZmin - DBZR(I,J,L) = DBZmin - DBZI(I,J,L) = DBZmin - DBZC(I,J,L) = DBZmin - ENDIF !(T(I,J,L) 1.0E-3) & RHOD=PMID(I,J,LL)/ & @@ -853,11 +821,7 @@ SUBROUTINE MDLFLD DBZ(i,j,ll) = ze_sum DBZR(i,j,ll) = ze_r*1.E18 DBZI(i,j,ll) = (ze_s+ze_g)*1.E18 - ELSE - DBZ(i,j,ll) = DBZmin - DBZR(i,j,ll) = DBZmin - DBZI(i,j,ll) = DBZmin - ENDIF !T(I,J,LL)>>>>>> upstream/develop GRID1(I,J)=T(I,J,LL)*(1.+D608*Q(I,J,LL)) - ELSE - GRID1(I,J)=spval - ENDIF ENDDO ENDDO if(grib=="grib2" )then @@ -1546,16 +1502,8 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(P1D(I,J)>>>>>> upstream/develop GRID1(I,J) = EGRID3(I,J) * (1.+D608*Q(I,J,LL)) - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -1592,20 +1540,10 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(P1D(I,J)>>>>>> upstream/develop GRID1(I,J) = EGRID4(I,J)*100. RH3D(I,J,LL) = GRID1(I,J) EGRID2(I,J) = Q(I,J,LL)/max(1.e-8,EGRID4(I,J)) ! Revert QS to compute cloud cover later - ELSE - GRID1(I,J) = spval - RH3D(I,J,LL) = spval - EGRID2(I,J) = spval - ENDIF ENDDO ENDDO IF (item > 0) then @@ -1640,16 +1578,8 @@ SUBROUTINE MDLFLD CALL CALDWP(P1D(1,jsta),Q1D(1,jsta),EGRID3(1,jsta),T1D(1,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(P1D(I,J)>>>>>> upstream/develop GRID1(I,J) = EGRID3(I,J) - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -1699,16 +1629,8 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(Q(I,J,LL)>>>>>> upstream/develop GRID1(I,J) = Q(I,J,LL) / (1.-Q(I,J,LL)) - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO CALL BOUND(GRID1,H1M12,H99999) @@ -1745,18 +1667,9 @@ SUBROUTINE MDLFLD CALL CALMCVG(Q1D,EGRID1,EGRID2,EGRID3) !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(Q1D(I,J)>>>>>> upstream/develop GRID1(I,J) = EGRID3(I,J) MCVG(I,J,LL) = EGRID3(I,J) - ELSE - GRID1(I,J) = spval - MCVG(I,J,LL) = spval - ENDIF ENDDO ENDDO IF(IGET(083)>0 .AND. LLL>0)THEN @@ -1877,16 +1790,8 @@ SUBROUTINE MDLFLD CALL CALVOR(EGRID1,EGRID2,EGRID3) !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(EGRID3(I,J)>>>>>> upstream/develop GRID1(I,J) = EGRID3(I,J) - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2097,16 +2002,8 @@ SUBROUTINE MDLFLD ENDIF !$omp parallel do DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(TRAIN(I,J,LL)>>>>>> upstream/develop GRID1(I,J) = TRAIN(I,J,LL)*RRNUM - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO ID(1:25) = 0 @@ -2157,16 +2054,8 @@ SUBROUTINE MDLFLD ENDIF !$omp parallel do DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(TCUCN(I,J,LL)>>>>>> upstream/develop GRID1(I,J) = TCUCN(I,J,LL)*RRNUM - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO ID(1:25) = 0 @@ -2238,16 +2127,8 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(PMID(I,J,LL)>>>>>> upstream/develop GRID1(I,J) = (1./RD)*(PMID(I,J,LL)/T(I,J,LL))*SMOKE(I,J,LL,1) - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2271,17 +2152,9 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(DUST(I,J,LL,1)>>>>>> upstream/develop !GRID1(I,J) = DUST(I,J,LL,1) GRID1(I,J) = DUST(I,J,LL,1)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2305,17 +2178,9 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(DUST(I,J,LL,2)>>>>>> upstream/develop !GRID1(I,J) = DUST(I,J,LL,2) GRID1(I,J) = DUST(I,J,LL,2)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2339,18 +2204,10 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(DUST(I,J,LL,3)>>>>>> upstream/develop !GRID1(I,J) = DUST(I,J,LL,3) GRID1(I,J) = DUST(I,J,LL,3)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 - ELSE - GRID1(I,J) = spval - ENDIF - ENDDO + ENDDO ENDDO if(grib=="grib2") then cfld=cfld+1 @@ -2373,17 +2230,9 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(DUST(I,J,LL,4)>>>>>> upstream/develop !GRID1(I,J) = DUST(I,J,LL,4) GRID1(I,J) = DUST(I,J,LL,4)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2407,17 +2256,9 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(DUST(I,J,LL,5)>>>>>> upstream/develop !GRID1(I,J) = DUST(I,J,LL,5) GRID1(I,J) = DUST(I,J,LL,5)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2441,16 +2282,8 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(SALT(I,J,LL,1)>>>>>> upstream/develop GRID1(I,J) = SALT(I,J,LL,1)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2474,16 +2307,8 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(SALT(I,J,LL,2)>>>>>> upstream/develop GRID1(I,J) = SALT(I,J,LL,2)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2507,16 +2332,8 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(SALT(I,J,LL,3)>>>>>> upstream/develop GRID1(I,J) = SALT(I,J,LL,3)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2540,16 +2357,8 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(SALT(I,J,LL,4)>>>>>> upstream/develop GRID1(I,J) = SALT(I,J,LL,4)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2573,16 +2382,8 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(SALT(I,J,LL,5)>>>>>> upstream/develop GRID1(I,J) = SALT(I,J,LL,5)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2606,17 +2407,9 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(SUSO(I,J,LL,1)>>>>>> upstream/develop !GRID1(I,J) = SUSO(I,J,LL,1) GRID1(I,J) = SUSO(I,J,LL,1)*RHOMID(I,J,LL) !lzhang ug/kg-->ug/m3 - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2640,17 +2433,9 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(WASO(I,J,LL,1)>>>>>> upstream/develop !GRID1(I,J) = WASO(I,J,LL,1) GRID1(I,J) = WASO(I,J,LL,1)*RHOMID(I,J,LL) !lzhang - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2674,17 +2459,9 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(WASO(I,J,LL,2)>>>>>> upstream/develop !GRID1(I,J) = WASO(I,J,LL,2) GRID1(I,J) = WASO(I,J,LL,2)*RHOMID(I,J,LL) !lzhang - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2708,17 +2485,9 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(SOOT(I,J,LL,1)>>>>>> upstream/develop !GRID1(I,J) = SOOT(I,J,LL,1) GRID1(I,J) = SOOT(I,J,LL,1)*RHOMID(I,J,LL) !lzhang - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2742,17 +2511,9 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(SOOT(I,J,LL,2)>>>>>> upstream/develop !GRID1(I,J) = SOOT(I,J,LL,2) GRID1(I,J) = SOOT(I,J,LL,2)*RHOMID(I,J,LL) !lzhang - ELSE - GRID1(I,J) = spval - ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2965,7 +2726,7 @@ SUBROUTINE MDLFLD 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)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) - IF(Q1D(I,J)0) THEN CALL CALVIS_GSD(CZEN,VIS) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J)=VIS(I,J) -======= - DO I=1,IM - IF(Q1D(I,J)>>>>>> upstream/develop END DO END DO if(grib=="grib2") then @@ -3656,16 +3398,8 @@ SUBROUTINE MDLFLD IF ( (IGET(389) > 0) .OR. (IGET(454) > 0) ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(PBLRI(I,J)>>>>>> upstream/develop EGRID3(I,J) = PBLRI(I,J) + ZINT(I,J,LM+1) - ELSE - EGRID3(I,J) = spval - ENDIF END DO END DO ! compute U and V separately because they are on different locations for B grid @@ -3683,15 +3417,8 @@ SUBROUTINE MDLFLD CALL H2U(PINT(1:IM,JSTA_2L:JEND_2U,L), EGRID7) HCOUNT=0 DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - if (EGRID4(I,J)>>>>>> upstream/develop if (EGRID5(I,J) <= EGRID4(I,J)) then ! if (I == 50 .and. J == 50) then ! write(0,*) 'working with L : ', L @@ -3703,7 +3430,6 @@ SUBROUTINE MDLFLD ! else ! exit vert_loopu endif - endif end do end do if(HCOUNT < 1 )exit vert_loopu @@ -3736,14 +3462,7 @@ SUBROUTINE MDLFLD CALL H2V(PINT(1:IM,JSTA_2L:JEND_2U,L), EGRID7) HCOUNT=0 DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - if (EGRID4(I,J)>>>>>> upstream/develop if (EGRID5(I,J) <= EGRID4(I,J)) then HCOUNT=HCOUNT+1 DP = EGRID6(I,J) - EGRID7(I,J) @@ -3752,7 +3471,6 @@ SUBROUTINE MDLFLD ! else ! exit vert_loopu endif - endif end do end do if(HCOUNT<1)exit vert_loopv @@ -4114,11 +3832,7 @@ SUBROUTINE MDLFLD icing_gfip = spval icing_gfis = spval DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM ->>>>>>> upstream/develop 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) diff --git a/sorc/ncep_post.fd/MISCLN.f b/sorc/ncep_post.fd/MISCLN.f index bd96ae79c..ee8bfdf6f 100644 --- a/sorc/ncep_post.fd/MISCLN.f +++ b/sorc/ncep_post.fd/MISCLN.f @@ -43,8 +43,6 @@ !! 19-09-03 J Meng - ADD CAPE related variables for HRRR !! 20-03-24 J Meng - remove grib1 !! 20-11-10 J Meng - USE UPP_PHYSICS MODULE -!! 21-03-25 E Colon - 3D-RTMA-specific SPC fields added as output -!! 21-04-01 J Meng - computation on defined points only !! !! USAGE: CALL MISCLN !! INPUT ARGUMENT LIST: @@ -83,24 +81,18 @@ SUBROUTINE MISCLN ! ! - use vrbls3d, only: pmid, uh, vh, t, zmid, zint, pint, alpint, q, omga + use vrbls3d, only: pmid, uh, vh, t, zmid, pint, alpint, q, omga use vrbls3d, only: catedr,mwt,gtg - use vrbls2d, only: pblh, cprate, fis, T500, T700, Z500, Z700,& - teql + use vrbls2d, only: pblh, cprate use masks, only: lmh - use params_mod, only: d00, d50, h99999, h100, h1, h1m12, pq0, a2, a3, a4, & - rhmin, rgamog, tfrz, small, g - use ctlblk_mod, only: grib, cfld, fld_info, datapd, im, jsta, jend, jm, jsta_m, jend_m, & + use params_mod, only: d00, h99999, h100, h1, h1m12, pq0, a2, a3, a4, & + rhmin, rgamog, tfrz, small + use ctlblk_mod, only: grib, cfld, fld_info, datapd, im, jsta, jend, jm, & nbnd, nbin_du, lm, htfd, spval, pthresh, nfd, petabnd, me,& -<<<<<<< HEAD jsta_2l, jend_2u, MODELNAME,ista,iend -======= - jsta_2l, jend_2u, MODELNAME, SUBMODELNAME ->>>>>>> upstream/develop use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml use grib2_module, only: pset - use upp_physics, only: FPVSNEW,CALRH_PW,CALCAPE,CALCAPE2,TVIRTUAL - use gridspec_mod, only: gridtype + use upp_physics, only: FPVSNEW, CALRH_PW, CALCAPE, CALCAPE2 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -113,12 +105,6 @@ SUBROUTINE MISCLN real,parameter :: con_eps =con_rd/con_rv real,parameter :: con_epsm1 =con_rd/con_rv-1 real,parameter :: cpthresh =0.000004 - real,PARAMETER :: D1000=1000 - real,PARAMETER :: D1500=1500 - real,PARAMETER :: D2000=2000 - real,PARAMETER :: HCONST=42000000. - real,PARAMETER :: K2C=273.16 - ! ! DECLARE VARIABLES. ! @@ -131,9 +117,7 @@ SUBROUTINE MISCLN real,dimension(im,jm) :: GRID1, GRID2 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 + EGRID5, EGRID6, EGRID7, EGRID8 real, dimension(:,:,:),allocatable :: OMGBND, PWTBND, QCNVBND, & PBND, TBND, QBND, & UBND, VBND, RHBND, & @@ -153,42 +137,28 @@ SUBROUTINE MISCLN real, dimension(:,:), allocatable :: USHR1, VSHR1, USHR6, VSHR6, & MAXWP, MAXWZ, MAXWU, MAXWV, & MAXWT +! MAXWT, RHPW INTEGER,dimension(:,:),allocatable :: LLOW, LUPP - REAL, dimension(:,:),allocatable :: CANGLE,ESHR,UVECT,VVECT,& - EFFUST,EFFVST,FSHR,HTSFC,& - ESRH + REAL, dimension(:,:),allocatable :: CANGLE ! integer I,J,jj,L,ITYPE,ISVALUE,LBND,ILVL,IFD,ITYPEFDLVL(NFD), & - iget1, iget2, iget3, LLMH + iget1, iget2, iget3 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, & - SCINtmp,MUCAPEtmp,MUCINtmp,MLLCLtmp,ESHRtmp,MLCAPEtmp,STP,& - FSHRtmp,MLCINtmp,SLCLtmp,LAPSE,SHIP + ES1,ES2,QS1,QS2,RH1,RH2,ZSF,DEPTH(2), work1, work2, work3 ! Variables introduced to allow FD levels from control file - Y Mao integer :: N,NFDCTL REAL, allocatable :: HTFDCTL(:) 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) ! !**************************************************************************** ! START MISCLN HERE. ! -<<<<<<< HEAD allocate(USHR1(ista:iend,jsta_2l:jend_2u),VSHR1(ista:iend,jsta_2l:jend_2u), & USHR6(ista:iend,jsta_2l:jend_2u),VSHR6(ista:iend,jsta_2l:jend_2u)) allocate(UST(ista:iend,jsta_2l:jend_2u),VST(ista:iend,jsta_2l:jend_2u), & HELI(ista:iend,jsta_2l:jend_2u,2)) -======= - 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)) ->>>>>>> upstream/develop ! ! HELICITY AND STORM MOTION. iget1 = IGET(162) @@ -309,15 +279,9 @@ SUBROUTINE MISCLN DEPTH = 6000.0 CALL CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) -! 0-6 km shear magnitude -!$omp parallel do private(i,j) - DO J=JSTA,JEND - DO I=1,IM - 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) +!$omp parallel do private(i,j,jj) DO J=JSTA,JEND DO I=ista,iend GRID1(I,J) = USHR1(I,J) @@ -1412,7 +1376,6 @@ SUBROUTINE MISCLN DO J=JSTA,JEND DO I=ista,iend GRID1(I,J)=Z1D(I,J) - IF (SUBMODELNAME == 'RTMA') FREEZELVL(I,J)=GRID1(I,J) ENDDO ENDDO CALL BOUND (GRID1,D00,H99999) @@ -1501,17 +1464,11 @@ SUBROUTINE MISCLN END IF ! HIGHEST FREEZING LEVEL RELATIVE HUMIDITY - IF (IGET(350)>0)THEN - GRID1=spval + IF (IGET(350)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J)=RH1D(I,J)*100. -======= - DO I=1,IM - IF(RH1D(I,J) < spval) GRID1(I,J)=RH1D(I,J)*100. ->>>>>>> upstream/develop ENDDO ENDDO CALL BOUND (GRID1,H1,H100) @@ -1580,16 +1537,10 @@ SUBROUTINE MISCLN ! HIGHEST -10C ISOTHERM RELATIVE HUMIDITY IF (IGET(777)>0)THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J)=RH1D(I,J)*100. -======= - DO I=1,IM - IF(RH1D(I,J) < spval) GRID1(I,J)=RH1D(I,J)*100. ->>>>>>> upstream/develop ENDDO ENDDO CALL BOUND (GRID1,H1,H100) @@ -1658,16 +1609,10 @@ SUBROUTINE MISCLN ! HIGHEST -20C ISOTHERM RELATIVE HUMIDITY IF (IGET(780)>0)THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J)=RH1D(I,J)*100. -======= - DO I=1,IM - IF(RH1D(I,J) < spval) GRID1(I,J)=RH1D(I,J)*100. ->>>>>>> upstream/develop ENDDO ENDDO CALL BOUND (GRID1,H1,H100) @@ -2140,12 +2085,7 @@ SUBROUTINE MISCLN QBND(1,jsta,LBND),EGRID1) !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - ->>>>>>> upstream/develop IF (EGRID1(I,J) > EGRID2(I,J)) THEN EGRID2(I,J) = EGRID1(I,J) LB2(I,J) = LVLBND(I,J,LBND) @@ -2247,16 +2187,10 @@ SUBROUTINE MISCLN CALL CALLCL(PBND(1,jsta,1),TBND(1,jsta,1), & QBND(1,jsta,1),EGRID1,EGRID2) IF (IGET(109)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J) = EGRID2(I,J) -======= - DO I=1,IM - IF(TBND(I,J,1) < spval) GRID1(I,J) = EGRID2(I,J) ->>>>>>> upstream/develop ENDDO ENDDO if(grib=='grib2') then @@ -2272,16 +2206,10 @@ SUBROUTINE MISCLN endif ENDIF IF (IGET(110)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J) = EGRID1(I,J) -======= - DO I=1,IM - IF(TBND(I,J,1) < spval) GRID1(I,J) = EGRID1(I,J) ->>>>>>> upstream/develop ENDDO ENDDO if(grib=='grib2') then @@ -2415,16 +2343,10 @@ SUBROUTINE MISCLN ! ! SIGMA 0.89671 TEMPERATURE IF (IGET(097) > 0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J) = T89671(I,J) -======= - DO I=1,IM - IF(T(I,J,LM) < spval) GRID1(I,J) = T89671(I,J) ->>>>>>> upstream/develop ! IF(T89671(I,J)>350.)PRINT*,'LARGE T89671 ', & ! I,J,T89671(I,J) ENDDO @@ -2445,16 +2367,10 @@ SUBROUTINE MISCLN ! ! SIGMA 0.78483 TEMPERATURE IF (IGET(098)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J) = T78483(I,J) -======= - DO I=1,IM - IF(T(I,J,LM) < spval) GRID1(I,J) = T78483(I,J) ->>>>>>> upstream/develop ENDDO ENDDO if(grib=='grib2') then @@ -2844,16 +2760,10 @@ SUBROUTINE MISCLN ! SIGMA 0.85000-1.00000 MOISTURE CONVERGENCE. IF (IGET(103)>0) THEN ! CONVERT TO DIVERGENCE FOR GRIB - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J) = -1.0*QM8510(I,J) -======= - DO I=1,IM - IF(QM8510(I,J) < spval) GRID1(I,J) = -1.0*QM8510(I,J) ->>>>>>> upstream/develop ENDDO ENDDO if(grib=='grib2') then @@ -2882,16 +2792,10 @@ SUBROUTINE MISCLN ! ! SIGMA 0.44-1.00 MEAN RELATIVE HUMIIDITY. IF (IGET(318)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J) = RH4410(I,J)*100. -======= - DO I=1,IM - IF(RH4410(I,J) < spval) GRID1(I,J) = RH4410(I,J)*100. ->>>>>>> upstream/develop ENDDO ENDDO CALL BOUND(GRID1,D00,H100) @@ -2911,16 +2815,10 @@ SUBROUTINE MISCLN ! ! SIGMA 0.72-0.94 MEAN RELATIVE HUMIIDITY. IF (IGET(319)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J) = RH7294(I,J)*100. -======= - DO I=1,IM - IF(RH7294(I,J) < spval) GRID1(I,J) = RH7294(I,J)*100. ->>>>>>> upstream/develop ENDDO ENDDO CALL BOUND(GRID1,D00,H100) @@ -2940,16 +2838,10 @@ SUBROUTINE MISCLN ! ! SIGMA 0.44-0.72 MEAN RELATIVE HUMIIDITY. IF (IGET(320)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J)=RH4472(I,J)*100. -======= - DO I=1,IM - IF(RH4472(I,J) < spval) GRID1(I,J)=RH4472(I,J)*100. ->>>>>>> upstream/develop ENDDO ENDDO CALL BOUND(GRID1,D00,H100) @@ -2972,7 +2864,7 @@ SUBROUTINE MISCLN ! GFS computes sigma=0.9950 T, THETA, U, V from lowest two model level fields IF ( (IGET(321)>0).OR.(IGET(322)>0).OR. & (IGET(323)>0).OR.(IGET(324)>0).OR. & - (IGET(325)>0).OR.(IGET(326)>0)) THEN + (IGET(325)>0).OR.(IGET(326)>0) ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND DO I=ista,iend @@ -2993,15 +2885,9 @@ SUBROUTINE MISCLN END DO ! Temperature IF (IGET(321)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(T(I,J,LM)>>>>>> upstream/develop GRID1(I,J) = T(I,J,LM)+(T(I,J,LM-1)-T(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -3023,15 +2909,9 @@ SUBROUTINE MISCLN ENDIF ! Potential Temperature IF (IGET(322)>0) THEN - GRID2=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(T(I,J,LM)>>>>>> upstream/develop GRID2(I,J) = T(I,J,LM)+(T(I,J,LM-1)-T(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -3052,16 +2932,9 @@ SUBROUTINE MISCLN ENDIF ! RH IF (IGET(323)>0) THEN - GRID1=spval !$omp parallel do private(i,j,es1,qs1,rh1,es2,qs2,rh2) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(PMID(I,J,LM)>>>>>> upstream/develop ES1 = min(PMID(I,J,LM),FPVSNEW(T(I,J,LM))) QS1 = CON_EPS*ES1/(PMID(I,J,LM)+CON_EPSM1*ES1) RH1 = Q(I,J,LM)/QS1 @@ -3069,7 +2942,6 @@ SUBROUTINE MISCLN QS2 = CON_EPS*ES2/(PMID(I,J,LM-1)+CON_EPSM1*ES2) RH2 = Q(I,J,LM-1)/QS2 GRID1(I,J) = (RH1+(RH2-RH1)*EGRID1(I,J))*100. - ENDIF ENDDO ENDDO CALL BOUND(GRID1,D00,H100) @@ -3088,15 +2960,9 @@ SUBROUTINE MISCLN ENDIF ! U IF (IGET(324)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(UH(I,J,LM)>>>>>> upstream/develop GRID1(I,J) = UH(I,J,LM)+(UH(I,J,LM-1)-UH(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -3116,15 +2982,9 @@ SUBROUTINE MISCLN ENDIF ! V IF (IGET(325)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(VH(I,J,LM)>>>>>> upstream/develop GRID1(I,J) = VH(I,J,LM)+(VH(I,J,LM-1)-VH(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -3144,15 +3004,9 @@ SUBROUTINE MISCLN ENDIF ! OMGA IF (IGET(326)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(OMGA(I,J,LM)>>>>>> upstream/develop GRID1(I,J) = OMGA(I,J,LM)+(OMGA(I,J,LM-1)-OMGA(I,J,LM)) & * EGRID1(I,J) ENDDO @@ -3215,23 +3069,16 @@ SUBROUTINE MISCLN CALL CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,LB2,EGRID1, & EGRID2,EGRID3,EGRID4,EGRID5) - IF (IGET(582)>0) THEN + IF (IGET(582)>0) THEN ! dong add missing value for cape GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) -======= - DO I=1,IM - IF(T1D(I,J) < spval) THEN - GRID1(I,J) = EGRID1(I,J) - IF (SUBMODELNAME == 'RTMA') MLCAPE(I,J)=GRID1(I,J) - ENDIF ->>>>>>> upstream/develop ENDDO ENDDO + CALL BOUND(GRID1,D00,H99999) if(grib=='grib2') then cfld=cfld+1 @@ -3260,16 +3107,8 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) -======= - DO I=1,IM - IF(T1D(I,J) < spval) THEN - GRID1(I,J) = - GRID1(I,J) - IF (SUBMODELNAME == 'RTMA') MLCIN(I,J) = GRID1(I,J) - ENDIF ->>>>>>> upstream/develop ENDDO ENDDO ! @@ -3285,13 +3124,13 @@ SUBROUTINE MISCLN enddo enddo endif + ENDIF ENDIF - + ! MIXED LAYER LIFTING CONDENSATION PRESSURE AND HEIGHT. ! EGRID1 IS LCL PRESSURE. EGRID2 IS LCL HEIGHT. ! -<<<<<<< HEAD ! IF ( (IGET(109)>0).OR.(IGET(110)>0) ) THEN ! CALL CALLCL(P1D,T1D,Q1D,EGRID1,EGRID2) ! IF (IGET(109)>0) THEN @@ -3300,29 +3139,12 @@ SUBROUTINE MISCLN ! GRID1(I,J)=EGRID2(I,J) ! ENDDO ! ENDDO -======= - IF ( (IGET(109)>0).OR.(IGET(110)>0) ) THEN - CALL CALLCL(P1D,T1D,Q1D,EGRID1,EGRID2) - IF (IGET(109)>0) THEN - GRID1=spval - DO J=JSTA,JEND - DO I=1,IM - IF(T1D(I,J) < spval) GRID1(I,J)=EGRID2(I,J) - IF (SUBMODELNAME == 'RTMA') MLLCL(I,J) = GRID1(I,J) - ENDDO - ENDDO ->>>>>>> upstream/develop ! ! ID(1:25) = 0 ! ! CALL GRIBIT(IGET(109),1, -<<<<<<< HEAD ! X GRIDista,iend,JM) ! ENDIF -======= -! X GRID1,IM,JM) - ENDIF ->>>>>>> upstream/develop ! ! IF (IGET(110)>0) THEN ! DO J=JSTA,JEND @@ -3336,7 +3158,7 @@ SUBROUTINE MISCLN ! CALL GRIBIT(IGET(110),1, ! X GRIDista,iend,JM) ! ENDIF - ENDIF +! ENDIF ! ! MOST UNSTABLE CAPE-LOWEST 300 MB ! @@ -3372,28 +3194,17 @@ SUBROUTINE MISCLN DPBND = 300.E2 CALL CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,LB2,EGRID1, & EGRID2,EGRID3,EGRID4,EGRID5) - IF (SUBMODELNAME == 'RTMA') MUMIXR(I,J) = Q1D(I,J) +! IF (IGET(584)>0) THEN ! dong add missing value to cin GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) -======= - DO I=1,IM - IF(T1D(I,J) < spval) THEN - GRID1(I,J) = EGRID1(I,J) - IF (SUBMODELNAME == 'RTMA') MUCAPE(I,J) = GRID1(I,J) - ENDIF ->>>>>>> upstream/develop ENDDO ENDDO CALL BOUND(GRID1,D00,H99999) -! IF (SUBMODELNAME == 'RTMA') THEN -! CALL BOUND(MUCAPE,D00,H99999) -! ENDIF if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(584)) @@ -3418,21 +3229,11 @@ SUBROUTINE MISCLN IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO + CALL BOUND(GRID1,D00,H99999) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) -======= - DO I=1,IM - IF(T1D(I,J) < spval) THEN - GRID1(I,J) = - GRID1(I,J) - IF (SUBMODELNAME == 'RTMA') THEN - MUCAPE(I,J) = GRID1(I,J) - MUQ1D(I,J) = Q1D(I,J) - ENDIF - ENDIF ->>>>>>> upstream/develop ENDDO ENDDO if(grib=='grib2') then @@ -3452,16 +3253,10 @@ SUBROUTINE MISCLN ! EQUILLIBRIUM HEIGHT IF (IGET(443)>0) THEN - GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J) = EGRID4(I,J) -======= - DO I=1,IM - IF(T1D(I,J) < spval) GRID1(I,J) = EGRID4(I,J) ->>>>>>> upstream/develop ENDDO ENDDO if(grib=='grib2') then @@ -3478,41 +3273,13 @@ SUBROUTINE MISCLN endif ENDIF -!Equilibrium Temperature - IF (IGET(982)>0) THEN - DO J=JSTA,JEND - DO I=1,IM - GRID1(I,J) = TEQL(I,J) - ENDDO - ENDDO - if(grib=='grib2') then - 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) - do j=1,jend-jsta+1 - jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) - enddo - enddo - endif - ENDIF - - ! PRESSURE OF LEVEL FROM WHICH 300 MB MOST UNSTABLE CAPE ! PARCEL WAS LIFTED (eq. PRESSURE OF LEVEL OF HIGHEST THETA-E) IF (IGET(246)>0) THEN - GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J) = EGRID3(I,J) -======= - DO I=1,IM - IF(T1D(I,J) < spval) GRID1(I,J) = EGRID3(I,J) ->>>>>>> upstream/develop ENDDO ENDDO CALL BOUND(GRID1,D00,H99999) @@ -3534,21 +3301,14 @@ SUBROUTINE MISCLN ! GENERAL THUNDER PARAMETER ??? 458 ??? IF (IGET(444)>0) THEN - GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend -======= - DO I=1,IM - IF(CPRATE(I,J) < spval) THEN ->>>>>>> upstream/develop IF (CPRATE(I,J) > PTHRESH) THEN GRID1(I,J) = EGRID5(I,J) ELSE GRID1(I,J) = 0 ENDIF - ENDIF ENDDO ENDDO CALL BOUND(GRID1,D00,H99999) @@ -3682,16 +3442,10 @@ SUBROUTINE MISCLN ! LFC HEIGHT IF (IGET(952)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J) = EGRID3(I,J) -======= - DO I=1,IM - IF(T1D(I,J) < spval) GRID1(I,J) = EGRID3(I,J) ->>>>>>> upstream/develop ENDDO ENDDO CALL BOUND(GRID1,D00,H99999) @@ -3711,6 +3465,8 @@ SUBROUTINE MISCLN ! EFFECTIVE STORM RELATIVE HELICITY AND STORM MOTION. + 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)) allocate(LLOW(IM,jsta_2l:jend_2u),LUPP(IM,jsta_2l:jend_2u), & @@ -3762,567 +3518,13 @@ SUBROUTINE MISCLN ENDIF !953 - IF (SUBMODELNAME == 'RTMA') THEN !Start RTMA block - -!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)) - -!get surface height - IF(gridtype == 'E')THEN - JVN = 1 - JVS = -1 - do J=JSTA,JEND - IVE(J) = MOD(J,2) - IVW(J) = IVE(J)-1 - enddo - ISTART = 2 - ISTOP = IM-1 - JSTART = JSTA_M - JSTOP = JEND_M - ELSE IF(gridtype == 'B')THEN - JVN = 1 - JVS = 0 - do J=JSTA,JEND - IVE(J)=1 - IVW(J)=0 - enddo - ISTART = 2 - ISTOP = IM-1 - JSTART = JSTA_M - JSTOP = JEND_M - ELSE - JVN = 0 - JVS = 0 - do J=JSTA,JEND - IVE(J) = 0 - IVW(J) = 0 - enddo - ISTART = 1 - ISTOP = IM - JSTART = JSTA - JSTOP = JEND - END IF - - IF(gridtype /= 'A') CALL EXCH(FIS(1:IM,JSTA:JEND)) - DO J=JSTART,JSTOP - DO I=ISTART,ISTOP - IE = I+IVE(J) - IW = I+IVW(J) - JN = J+JVN - JS = J+JVS - IF (gridtype=='B')THEN - HTSFC(I,J)=(0.25/g)*(FIS(IW,J)+FIS(IE,J)+FIS(I,JN)+FIS(IE,JN)) - ELSE - HTSFC(I,J)=(0.25/g)*(FIS(IW,J)+FIS(IE,J)+FIS(I,JN)+FIS(I,JS)) - ENDIF - ENDDO - ENDDO - -!Height of effbot - IF (IGET(979)>0) THEN - GRID1=spval - DO J=JSTA,JEND - DO I=1,IM - IF(ZINT(I,J,LLOW(I,J))0) THEN - GRID1=spval - DO J=JSTA,JEND - DO I=1,IM - IF(ZINT(I,J,LUPP(I,J))0) THEN - GRID1=spval - DO J=JSTA,JEND - DO I=1,IM - IF(LLOW(I,J)0) THEN - GRID1=spval - DO J=JSTA,JEND - DO I=1,IM - IF(LLOW(I,J)0) THEN - GRID1=spval - DO J=JSTA,JEND - DO I=1,IM - IF(UVECT(I,J)0) THEN - GRID1=spval - DO J=JSTA,JEND - DO I=1,IM - IF(LLOW(I,J)0) THEN - GRID1=spval - DO J=JSTA,JEND - DO I=1,IM - IF(LLOW(I,J)0) THEN - GRID1=spval - DO J=JSTA,JEND - DO I=1,IM - IF(LLOW(I,J)0) THEN - DO J=JSTA,JEND - DO I=1,IM - IF (MLLCL(I,J)>D2000) THEN - MLLCLtmp=D00 - ELSEIF (MLLCL(I,J)30.0) THEN - ESHRtmp=1.5 - ELSE - ESHRtmp=(ESHR(I,J)/20.) - ENDIF - IF (MLCIN(I,J)>-50.) THEN - MLCINtmp=1.0 - ELSEIF (MLCIN(I,J)<-200.) THEN - MLCINtmp=D00 - ELSE - MLCINtmp=(200.+MLCIN(I,J))/150. - ENDIF - STP=(MLCAPE(I,J)/D1500)*MLLCLtmp*(ESRH(I,J)/150.)*& - ESHRtmp*MLCINtmp - GRID1(I,J) = SPVAL - IF(LLOW(I,J)0) THEN - GRID1(I,J)=STP - ELSE - GRID1(I,J)=D00 - ENDIF - ENDIF - ENDDO - ENDDO - if(grib=='grib2') then - cfld=cfld+1 - fld_info(cfld)%ifld=IAVBLFLD(IGET(989)) - fld_info(cfld)%lvl=LVLSXML(1,IGET(989)) -! $omp parallel do private(i,j,jj) - do j=1,jend-jsta+1 - jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) - enddo - enddo - endif - ENDIF - -!Fixed Layer Tornado Parameter - IF (IGET(990)>0) THEN - DO J=JSTA,JEND - DO I=1,IM - LLMH = NINT(LMH(I,J)) - P1D(I,J) = PMID(I,J,LLMH) - T1D(I,J) = T(I,J,LLMH) - Q1D(I,J) = Q(I,J,LLMH) - ENDDO - ENDDO - CALL CALLCL(P1D,T1D,Q1D,EGRID1,EGRID2) - DO J=JSTA,JEND - DO I=1,IM - SLCL(I,J)=EGRID2(I,J) - ENDDO - ENDDO - ITYPE = 1 - DPBND = 10.E2 - dummy = 0. - idummy = 0 - CALL CALCAPE(ITYPE,DPBND,dummy,dummy,dummy,& - idummy,EGRID1,EGRID2,& - EGRID3,dummy,dummy) - - DO J=JSTA,JEND - DO I=1,IM - IF (SLCL(I,J)>D2000) THEN - SLCLtmp=D00 - ELSEIF (SLCL(I,J)<=D1000) THEN - SLCLtmp=1.0 - ELSE - SLCLtmp=((D2000-SLCL(I,J))/D1000) - ENDIF - IF (FSHR(I,J)<12.5) THEN - FSHRtmp=D00 - ELSEIF (FSHR(I,J)>30.0) THEN - FSHRtmp=1.5 - ELSE - FSHRtmp=(FSHR(I,J)/20.) - ENDIF - IF (EGRID2(I,J)>-50.) THEN - SCINtmp=1.0 - ELSEIF (EGRID2(I,J)<-200.) THEN - SCINtmp=D00 - ELSE - SCINtmp=((200.+EGRID2(I,J)/150.)) - ENDIF - STP=(EGRID1(I,J)/D1500)*SLCLtmp*(HELI(I,J,2)/150.)*& - FSHRtmp*SCINtmp - GRID1(I,J) = spval - IF(T1D(I,J) < spval) THEN - IF (STP>0) THEN - GRID1(I,J)=STP - ELSE - GRID1(I,J)=D00 - ENDIF - ENDIF - ENDDO - ENDDO - if(grib=='grib2') then - 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) - do j=1,jend-jsta+1 - jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) - enddo - enddo - endif - ENDIF - -!Effective Layer Supercell Parameter - IF (IGET(991)>0) THEN - DO J=JSTA,JEND - DO I=1,IM - IF (ESHR(I,J)<10.) THEN - ESHRtmp=D00 - ELSEIF (ESHR(I,J)>20.0) THEN - ESHRtmp=1 - ELSE - ESHRtmp=(ESHR(I,J)/20.) - ENDIF - IF (MUCIN(I,J)>-40.) THEN - MUCINtmp=1.0 - ELSE - MUCINtmp=(-40./MUCIN(I,J)) - ENDIF - STP=(MUCAPE(I,J)/D1000)*(ESRH(I,J)/50.)*& - ESHRtmp*MUCINtmp - GRID1(I,J) = spval - IF(T1D(I,J) < spval) THEN - IF (STP>0) THEN - GRID1(I,J)=STP - ELSE - GRID1(I,J)=D00 - ENDIF - ENDIF - ENDDO - ENDDO - if(grib=='grib2') then - 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) - do j=1,jend-jsta+1 - jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) - enddo - enddo - endif - ENDIF - -!Mixed Layer (100 mb) Virtual LFC - - IF (IGET(992)>0) THEN -!$omp parallel do private(i,j) - DO J=JSTA,JEND - DO I=1,IM - EGRID1(I,J) = -H99999 - EGRID2(I,J) = -H99999 - EGRID3(I,J) = -H99999 - EGRID4(I,J) = -H99999 - EGRID5(I,J) = -H99999 - EGRID6(I,J) = -H99999 - EGRID7(I,J) = -H99999 - EGRID8(I,J) = -H99999 - LB2(I,J) = (LVLBND(I,J,1) + LVLBND(I,J,2) + & - LVLBND(I,J,3))/3 - P1D(I,J) = (PBND(I,J,1) + PBND(I,J,2) + PBND(I,J,3))/3 - T1D(I,J) = (TVIRTUAL(TBND(I,J,1),QBND(I,J,1)) + & - TVIRTUAL(TBND(I,J,2),QBND(I,J,2)) + & - TVIRTUAL(TBND(I,J,3),QBND(I,J,3)))/3 - Q1D(I,J) = (QBND(I,J,1) + QBND(I,J,2) + QBND(I,J,3))/3 - ENDDO - ENDDO - - DPBND = 0. - ITYPE = 2 -! EGRID3 is Virtual LFC - CALL CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,LB2, & - EGRID1,EGRID2,EGRID3,EGRID4,EGRID5, & - EGRID6,EGRID7,EGRID8) - GRID1=spval - DO J=JSTA,JEND - DO I=1,IM - IF(T1D(I,J) < spval) GRID1(I,J) = EGRID3(I,J) - ENDDO - ENDDO - CALL BOUND(GRID1,D00,H99999) - if(grib=='grib2') then - 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) - do j=1,jend-jsta+1 - jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) - enddo - enddo - endif - ENDIF !992 - - - IF (IGET(763)>0) THEN -!$omp parallel do private(i,j) -! EGRID3 is Virtual LFC - DO J=JSTA,JEND - DO I=1,IM - GRID1(I,J) = Q1D(I,J) - ENDDO - ENDDO - if(grib=='grib2') then - 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) - do j=1,jend-jsta+1 - jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) - enddo - enddo - endif - ENDIF - -!Hail parameter - IF (IGET(993)>0) THEN - GRID1=spval - DO J=JSTA,JEND - DO I=1,IM - IF(T700(I,J) < spval .and. T500(I,J) < spval .and.& - Z700(I,J) < spval .and. Z500(I,J) < spval .and.& - MUCAPE(I,J) < spval .and. MUQ1D(I,J) < spval .and. FSHR(I,J) < spval) THEN - 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 - SHIP=SHIP*(MUCAPE(I,J)/1300.) - ENDIF - IF (LAPSE < 5.8)THEN - SHIP=SHIP*(LAPSE/5.8) - ENDIF - IF (FREEZELVL(I,J) < 2400.)THEN - SHIP=SHIP*(FREEZELVL(I,J)/2400.) - ENDIF - GRID1(I,J)=SHIP - ENDIF - ENDDO - ENDDO - if(grib=='grib2') then - 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) - do j=1,jend-jsta+1 - jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) - enddo - enddo - endif - ENDIF - - ENDIF !END RTMA BLOCK - - ! Critical Angle IF (IGET(957)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J) = CANGLE(I,J) -======= - DO I=1,IM - IF(T1D(I,J) < spval ) GRID1(I,J) = CANGLE(I,J) ->>>>>>> upstream/develop ! IF(EGRID1(I,J)<100. .OR. EGRID2(I,J)>-250.) THEN ! GRID1(I,J) = 0. ! ENDIF @@ -4345,16 +3547,10 @@ SUBROUTINE MISCLN ! Dendritic Layer Depth, -17C < T < -12C IF (IGET(955)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J) = EGRID7(I,J) -======= - DO I=1,IM - IF(T1D(I,J) < spval ) GRID1(I,J) = EGRID7(I,J) ->>>>>>> upstream/develop ENDDO ENDDO CALL BOUND(GRID1,D00,H99999) @@ -4375,16 +3571,10 @@ SUBROUTINE MISCLN ! Enhanced Stretching Potential IF (IGET(956)>0) THEN - GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD DO I=ista,iend GRID1(I,J) = EGRID8(I,J) -======= - DO I=1,IM - IF(T1D(I,J) < spval ) GRID1(I,J) = EGRID8(I,J) ->>>>>>> upstream/develop ENDDO ENDDO CALL BOUND(GRID1,D00,H99999) @@ -4454,14 +3644,7 @@ SUBROUTINE MISCLN if (allocated(llow)) deallocate(llow) if (allocated(lupp)) deallocate(lupp) if (allocated(cangle))deallocate(cangle) - if (allocated(effust))deallocate(effust) - if (allocated(effvst))deallocate(effvst) - if (allocated(eshr)) deallocate(eshr) - if (allocated(uvect)) deallocate(uvect) - if (allocated(vvect)) deallocate(vvect) - if (allocated(esrh)) deallocate(esrh) - if (allocated(htsfc)) deallocate(htsfc) - if (allocated(fshr)) deallocate(fshr) + ENDIF if (allocated(pbnd)) deallocate(pbnd) diff --git a/sorc/ncep_post.fd/PROCESS.f b/sorc/ncep_post.fd/PROCESS.f index 848890403..dfbf39471 100644 --- a/sorc/ncep_post.fd/PROCESS.f +++ b/sorc/ncep_post.fd/PROCESS.f @@ -55,7 +55,6 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! use IFCORE use CTLBLK_mod, only: cfld, etafld2_tim, eta2p_tim, mdl2sigma_tim, surfce2_tim,& - mdl2agl_tim, mdl2std_tim, mdl2thandpv_tim, calrad_wcloud_tim,& cldrad_tim, miscln_tim, fixed_tim, ntlfld, me !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -97,10 +96,7 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) CALL MDL2SIGMA2 MDL2SIGMA_tim = MDL2SIGMA_tim +(timef() - btim) ! -! COMPUTE/POST FIELDS ON AGL SURFCES. - btim = timef() CALL MDL2AGL - MDL2AGL_tim = MDL2AGL_tim +(timef() - btim) ! ! COMPUTE/POST SURFACE RELATED FIELDS. btim = timef() @@ -124,7 +120,6 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! AND LFM-NGM LOOK-ALIKE FIELDS. btim = timef() CALL MDL2STD_P - MDL2STD_tim = MDL2STD_tim +(timef() - btim) ! ! POST FIXED FIELDS. btim = timef() @@ -134,12 +129,10 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! COMPUTE/POST FIELDS ON SIGMA SURFACES. btim = timef() CALL MDL2THANDPV(kth,kpv,th,pv) - MDL2THANDPV_tim = MDL2THANDPV_tim +(timef() - btim) ! ! POST RADIANCE AND BRIGHTNESS FIELDS. btim = timef() CALL CALRAD_WCLOUD - CALRAD_WCLOUD_tim = CALRAD_WCLOUD_tim +(timef() - btim) ! ! END OF ROUTINE. ! diff --git a/sorc/ncep_post.fd/SURFCE.f b/sorc/ncep_post.fd/SURFCE.f index 1e9b12a68..1225d3c9f 100644 --- a/sorc/ncep_post.fd/SURFCE.f +++ b/sorc/ncep_post.fd/SURFCE.f @@ -36,14 +36,9 @@ !! - 20-03-25 J MENG - remove grib1 !! - 20-05-20 J MENG - CALRH unification with NAM scheme !! - 20-11-10 J MENG - USE UPP_PHYSICS MODULE -<<<<<<< HEAD !! 03/26/20 George Vandenberghe. Added support for 2D !! decomposition in I as well as J. Changed array allocaton ranges and !! loop boundaries -======= -!! - 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) -!! - 21-04-01 J MENG - COMPUTATION ON DEFINED POINTS ONLY ->>>>>>> upstream/develop !! !! USAGE: CALL SURFCE !! INPUT ARGUMENT LIST: @@ -138,18 +133,10 @@ SUBROUTINE SURFCE domip, domzr, rsmin, smcref,& rcq, rct, rcsoil, gc, rcs -<<<<<<< HEAD real, dimension(ista:iend,jsta:jend) :: evp real, dimension(ista:iend,jsta_2l:jend_2u) :: egrid1, egrid2 real, dimension(im,jm) :: grid1, grid2 real, dimension(ista:iend,jsta_2l:jend_2u) :: iceg -======= - real, dimension(im,jsta:jend) :: evp - real, dimension(im,jsta_2l:jend_2u) :: egrid1, egrid2 - real, dimension(im,jsta_2l:jend_2u) :: grid2 - real, dimension(im,jm) :: grid1 - real, dimension(im,jsta_2l:jend_2u) :: iceg ->>>>>>> upstream/develop ! , ua, va real, allocatable, dimension(:,:,:) :: sleet, rain, freezr, snow ! real, dimension(im,jm,nalg) :: sleet, rain, freezr, snow @@ -165,7 +152,6 @@ SUBROUTINE SURFCE real RDTPHS,TLOW,TSFCK,QSAT,DTOP,DBOT,SNEQV,RRNUM,SFCPRS,SFCQ, & RC,SFCTMP,SNCOVR,FACTRS,SOLAR, s,tk,tl,w,t2c,dlt,APE, & qv,e,dwpt,dum1,dum2,dum3,dum1s,dum3s,dum21,dum216,es - logical, parameter :: debugprint = .false. !**************************************************************************** @@ -184,15 +170,9 @@ SUBROUTINE SURFCE (IGET(154)>0).OR. & (IGET(034)>0).OR.(IGET(076)>0) ) THEN ! -<<<<<<< HEAD allocate(zsfc(ista:iend,jsta:jend), psfc(ista:iend,jsta:jend), tsfc(ista:iend,jsta:jend)& ,rhsfc(ista:iend,jsta:jend), thsfc(ista:iend,jsta:jend), qsfc(ista:iend,jsta:jend)) !$omp parallel do private(i,j,tsfck,qsat) -======= - allocate(zsfc(im,jsta:jend), psfc(im,jsta:jend), tsfc(im,jsta:jend)& - ,rhsfc(im,jsta:jend), thsfc(im,jsta:jend), qsfc(im,jsta:jend)) -!$omp parallel do private(i,j,tsfck,qsat,es) ->>>>>>> upstream/develop DO J=JSTA,JEND do i=ista,iend ! @@ -1273,7 +1253,7 @@ SUBROUTINE SURFCE ! ! SHELTER LEVEL TEMPERATURE IF (IGET(106)>0) THEN - GRID1=SPVAL +! GRID1=spval DO J=JSTA,JEND do i=ista,iend ! GRID1(I,J)=TSHLTR(I,J) @@ -1416,28 +1396,20 @@ SUBROUTINE SURFCE ! IF ((IGET(547)>0).OR.(IGET(548)>0)) THEN - GRID1=SPVAL - GRID2=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend -======= - DO I=1,IM - if(TSHLTR(I,J)/=spval.and.PSHLTR(I,J)/=spval.and.QSHLTR(I,J)/=spval) then ->>>>>>> upstream/develop ! DEWPOINT DEPRESSION in GRID1 GRID1(i,j)=max(0.,TSHLTR(I,J)*(PSHLTR(I,J)*1.E-5)**CAPA-EGRID1(i,j)) ! SURFACE EQIV POT TEMP in GRID2 APE=(H10E5/PSHLTR(I,J))**CAPA GRID2(I,J)=TSHLTR(I,J)*EXP(ELOCP*QSHLTR(I,J)*APE/TSHLTR(I,J)) - endif ENDDO ENDDO -! print *,' MAX/MIN --> DEWPOINT DEPRESSION',maxval(grid1(1:im,jsta:jend)),& -! minval(grid1(1:im,jsta:jend)) -! print *,' MAX/MIN --> SFC EQUIV POT TEMP',maxval(grid2(1:im,jsta:jend)),& -! minval(grid2(1:im,jsta:jend)) + print *,' MAX/MIN --> DEWPOINT DEPRESSION',maxval(grid1(1:im,jsta:jend)),& + minval(grid1(1:im,jsta:jend)) + print *,' MAX/MIN --> SFC EQUIV POT TEMP',maxval(grid2(1:im,jsta:jend)),& + minval(grid2(1:im,jsta:jend)) IF (IGET(547)>0) THEN if(grib=='grib2') then @@ -1507,15 +1479,9 @@ SUBROUTINE SURFCE ENDIF IF(IGET(808)>0)THEN - GRID2=SPVAL !$omp parallel do private(i,j,dum1,dum2,dum3,dum216,dum1s,dum3s) DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend -======= - DO I=1,IM - if(T1D(I,J)/=spval.and.U10H(I,J)/=spval.and.V10H(I,J)>>>>>> upstream/develop DUM1 = (T1D(I,J)-TFRZ)*1.8+32. DUM2 = SQRT(U10H(I,J)**2.0+V10H(I,J)**2.0)/0.44704 DUM3 = EGRID1(I,J) * 100.0 @@ -1543,7 +1509,6 @@ SUBROUTINE SURFCE END IF ! if(abs(gdlon(i,j)-120.)<1. .and. abs(gdlat(i,j))<1.) & ! print*,'Debug AT: OUTPUT',Grid2(i,j) - endif ENDDO ENDDO @@ -1683,15 +1648,9 @@ SUBROUTINE SURFCE ! ! SHELTER LEVEL MAX RH. IF (IGET(347)>0) THEN - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J)=MAXRHSHLTR(I,J)*100. -======= - DO I=1,IM - if(MAXRHSHLTR(I,J)/=spval) GRID1(I,J)=MAXRHSHLTR(I,J)*100. ->>>>>>> upstream/develop ENDDO ENDDO ID(1:25) = 0 @@ -1726,8 +1685,8 @@ SUBROUTINE SURFCE ! fld_info(cfld)%tinvstat=ITMAXMIN fld_info(cfld)%tinvstat=IFHR-ID(18) if(IFHR==0) fld_info(cfld)%tinvstat=0 -! print*,'id(18),tinvstat,IFHR,ITMAXMIN in rhmax= ',ID(18),fld_info(cfld)%tinvstat, & -! IFHR, ITMAXMIN + print*,'id(18),tinvstat,IFHR,ITMAXMIN in rhmax= ',ID(18),fld_info(cfld)%tinvstat, & + IFHR, ITMAXMIN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 @@ -1740,15 +1699,9 @@ SUBROUTINE SURFCE ! ! SHELTER LEVEL MIN RH. IF (IGET(348)>0) THEN - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J)=MINRHSHLTR(I,J)*100. -======= - DO I=1,IM - if(MINRHSHLTR(I,J)/=spval) GRID1(I,J)=MINRHSHLTR(I,J)*100. ->>>>>>> upstream/develop ENDDO ENDDO ID(1:25) = 0 @@ -1875,14 +1828,8 @@ SUBROUTINE SURFCE ! E. James - 12 Sep 2018: SMOKE from WRF-CHEM on lowest model level ! IF (IGET(739)>0) THEN - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend -======= - DO I=1,IM - if(T(I,J,LM)/=spval.and.PMID(I,J,LM)/=spval.and.SMOKE(I,J,LM,1)/=spval)& ->>>>>>> upstream/develop GRID1(I,J) = (1./RD)*(PMID(I,J,LM)/T(I,J,LM))*SMOKE(I,J,LM,1) ENDDO ENDDO @@ -1937,7 +1884,7 @@ SUBROUTINE SURFCE ENDDO ENDDO if(grib=='grib2') then -! print*,'Outputting time-averaged winds' + print*,'Outputting time-averaged winds' cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(730)) if(fld_info(cfld)%ntrange==0) then @@ -2319,16 +2266,10 @@ SUBROUTINE SURFCE IF (IGET(249)>0) THEN RDTPHS=1000./DTQ2 !--- 1000 kg/m**3, density of liquid water ! RDTPHS=1000./(TRDLW*3600.) - GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J) = CPRATE(I,J)*RDTPHS -======= - DO I=1,IM - if(CPRATE(I,J)/=spval) GRID1(I,J) = CPRATE(I,J)*RDTPHS ->>>>>>> upstream/develop ! GRID1(I,J) = CUPPT(I,J)*RDTPHS ENDDO ENDDO @@ -2350,21 +2291,14 @@ SUBROUTINE SURFCE !MEB need to get physics DT RDTPHS=1./(DTQ2) !MEB need to get physics DT - GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend -======= - DO I=1,IM - if(PREC(I,J)/=spval) then ->>>>>>> upstream/develop IF(MODELNAME /= 'RSM') THEN GRID1(I,J) = PREC(I,J)*RDTPHS*1000. ELSE !Add by Binbin GRID1(I,J) = PREC(I,J) END IF - endif ENDDO ENDDO if(grib=='grib2') then @@ -2383,15 +2317,9 @@ SUBROUTINE SURFCE ! MAXIMUM INSTANTANEOUS PRECIPITATION RATE. IF (IGET(508)>0) THEN !-- PRATE_MAX in units of mm/h from NMMB history files - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J)=PRATE_MAX(I,J)*SEC2HR -======= - DO I=1,IM - if(PRATE_MAX(I,J)/=spval) GRID1(I,J)=PRATE_MAX(I,J)*SEC2HR ->>>>>>> upstream/develop ENDDO ENDDO if(grib=='grib2') then @@ -2417,15 +2345,9 @@ SUBROUTINE SURFCE ! MAXIMUM INSTANTANEOUS *FROZEN* PRECIPITATION RATE. IF (IGET(509)>0) THEN !-- FPRATE_MAX in units of mm/h from NMMB history files - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J)=FPRATE_MAX(I,J)*SEC2HR -======= - DO I=1,IM - if(FPRATE_MAX(I,J)/=spval) GRID1(I,J)=FPRATE_MAX(I,J)*SEC2HR ->>>>>>> upstream/develop ENDDO ENDDO if(grib=='grib2') then @@ -2604,16 +2526,8 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend -======= - DO I=1,IM - IF(ACPREC(I,J) < SPVAL)THEN ->>>>>>> upstream/develop GRID1(I,J) = ACPREC(I,J)*1000. - ELSE - GRID1(I,J) = SPVAL - ENDIF ENDDO ENDDO END IF @@ -2758,16 +2672,8 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend -======= - DO I=1,IM - IF(CUPREC(I,J) < SPVAL)THEN ->>>>>>> upstream/develop GRID1(I,J) = CUPREC(I,J)*1000. - ELSE - GRID1(I,J) = SPVAL - ENDIF ENDDO ENDDO END IF @@ -2997,14 +2903,13 @@ SUBROUTINE SURFCE ! ! ACCUMULATED LAND SURFACE PRECIPITATION. IF (IGET(256)>0) THEN - GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND do i=ista,iend IF(LSPA(I,J)<=-1.0E-6)THEN - if(ACPREC(I,J)/=spval) GRID1(I,J) = ACPREC(I,J)*1000 + GRID1(I,J) = ACPREC(I,J)*1000 ELSE - if(LSPA(I,J)/=spval) GRID1(I,J) = LSPA(I,J)*1000. + GRID1(I,J) = LSPA(I,J)*1000. END IF ENDDO ENDDO @@ -3521,9 +3426,7 @@ SUBROUTINE SURFCE IF (ID(18)<0) ID(18) = 0 ! print *,'IFMIN,IFHR,ITPREC',IFMIN,IFHR,ITPREC - if(debugprint .and. me==0)then - print *,'PREC_ACC_DT,ID(18),ID(19)',PREC_ACC_DT,ID(18),ID(19) - endif + if(me==0)print *,'PREC_ACC_DT,ID(18),ID(19)',PREC_ACC_DT,ID(18),ID(19) if(grib=='grib2') then cfld=cfld+1 @@ -3643,7 +3546,7 @@ SUBROUTINE SURFCE IF(IFMIN >= 1)ID(18)=IFHR*60+IFMIN-IFINCR ENDIF IF (ID(18)<0) ID(18) = 0 -! if(me==0)print*,'maxval BUCKET SNOWFALL: ', maxval(GRID1) + if(me==0)print*,'maxval BUCKET SNOWFALL: ', maxval(GRID1) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(437)) @@ -3701,7 +3604,7 @@ SUBROUTINE SURFCE IF(IFMIN >= 1)ID(18)=IFHR*60+IFMIN-IFINCR ENDIF IF (ID(18)<0) ID(18) = 0 -! print*,'maxval BUCKET GRAUPEL: ', maxval(GRID1) + print*,'maxval BUCKET GRAUPEL: ', maxval(GRID1) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(775)) @@ -3843,7 +3746,7 @@ SUBROUTINE SURFCE ENDDO ENDDO IFINCR = NINT(PREC_ACC_DT1) -! if(me==0)print*,'maxval BUCKET1 SNOWFALL: ', maxval(GRID1) + if(me==0)print*,'maxval BUCKET1 SNOWFALL: ', maxval(GRID1) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(521)) @@ -3877,7 +3780,7 @@ SUBROUTINE SURFCE ENDDO ENDDO IFINCR = NINT(PREC_ACC_DT1) -! print*,'maxval BUCKET1 GRAUPEL: ', maxval(GRID1) + print*,'maxval BUCKET1 GRAUPEL: ', maxval(GRID1) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(522)) @@ -4831,15 +4734,9 @@ SUBROUTINE SURFCE ELSE RRNUM=0. ENDIF - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J) = SUBSHX(I,J)*RRNUM -======= - DO I=1,IM - if(SUBSHX(I,J)/=spval) GRID1(I,J) = SUBSHX(I,J)*RRNUM ->>>>>>> upstream/develop ENDDO ENDDO ID(1:25) = 0 @@ -4886,15 +4783,9 @@ SUBROUTINE SURFCE ELSE RRNUM=0. ENDIF - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J) = SNOPCX(I,J)*RRNUM -======= - DO I=1,IM - if(SNOPCX(I,J)/=spval) GRID1(I,J) = SNOPCX(I,J)*RRNUM ->>>>>>> upstream/develop ENDDO ENDDO ID(1:25) = 0 @@ -4994,15 +4885,9 @@ SUBROUTINE SURFCE ELSE RRNUM=0. ENDIF - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J) = SFCUX(I,J)*RRNUM -======= - DO I=1,IM - if(SFCUX(I,J)/=spval) GRID1(I,J) = SFCUX(I,J)*RRNUM ->>>>>>> upstream/develop ENDDO ENDDO ID(1:25) = 0 @@ -5049,15 +4934,9 @@ SUBROUTINE SURFCE ELSE RRNUM=0. ENDIF - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J) = SFCVX(I,J)*RRNUM -======= - DO I=1,IM - if(SFCVX(I,J)/=spval) GRID1(I,J) = SFCVX(I,J)*RRNUM ->>>>>>> upstream/develop ENDDO ENDDO ID(1:25) = 0 @@ -5094,15 +4973,9 @@ SUBROUTINE SURFCE ! ! ACCUMULATED SURFACE EVAPORATION IF (IGET(047)>0) THEN - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J) = SFCEVP(I,J)*1000. -======= - DO I=1,IM - if(SFCEVP(I,J)/=spval) GRID1(I,J) = SFCEVP(I,J)*1000. ->>>>>>> upstream/develop ENDDO ENDDO ID(1:25) = 0 @@ -5142,15 +5015,9 @@ SUBROUTINE SURFCE ! ! ACCUMULATED POTENTIAL EVAPORATION IF (IGET(137)>0) THEN - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J) = POTEVP(I,J)*1000. -======= - DO I=1,IM - if(POTEVP(I,J)/=spval) GRID1(I,J) = POTEVP(I,J)*1000. ->>>>>>> upstream/develop ENDDO ENDDO ID(1:25) = 0 @@ -5483,15 +5350,9 @@ SUBROUTINE SURFCE ! ! GREEN VEG FRACTION IF (IGET(170)>0) THEN - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J)=VEGFRC(I,J)*100. -======= - DO I=1,IM - if(VEGFRC(I,J)/=spval) GRID1(I,J)=VEGFRC(I,J)*100. ->>>>>>> upstream/develop ENDDO ENDDO if(grib=='grib2') then @@ -5504,15 +5365,9 @@ SUBROUTINE SURFCE ! ! MIN GREEN VEG FRACTION IF (IGET(726)>0) THEN - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J)=shdmin(I,J)*100. -======= - DO I=1,IM - if(shdmin(I,J)/=spval) GRID1(I,J)=shdmin(I,J)*100. ->>>>>>> upstream/develop ENDDO ENDDO if(grib=='grib2') then @@ -5524,15 +5379,9 @@ SUBROUTINE SURFCE ! ! MAX GREEN VEG FRACTION IF (IGET(729)>0) THEN - GRID1=SPVAL DO J=JSTA,JEND -<<<<<<< HEAD do i=ista,iend GRID1(I,J)=shdmax(I,J)*100. -======= - DO I=1,IM - if(shdmax(I,J)/=spval) GRID1(I,J)=shdmax(I,J)*100. ->>>>>>> upstream/develop ENDDO ENDDO if(grib=='grib2') then @@ -5618,7 +5467,7 @@ SUBROUTINE SURFCE datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF -! if (me==0)print*,'starting computing canopy conductance' + if (me==0)print*,'starting computing canopy conductance' ! ! CANOPY CONDUCTANCE ! ONLY OUTPUT NEW LSM FIELDS FOR NMM AND ARW BECAUSE RSM USES OLD SOIL TYPES @@ -5630,7 +5479,7 @@ SUBROUTINE SURFCE & .OR. IGET(239)>0 .OR. IGET(240)>0 & & .OR. IGET(241)>0 ) THEN IF (iSF_SURFACE_PHYSICS == 2) THEN !NSOIL == 4 -! if(me==0)print*,'starting computing canopy conductance' + 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)) DO J=JSTA,JEND @@ -5974,7 +5823,7 @@ SUBROUTINE SURFCE DO L=1,LM IF(PMID(1,1,L)>=(PDTOP+PT))EXIT END DO -! PRINT*,'hybrid boundary ',L + PRINT*,'hybrid boundary ',L END IF CALL MPI_BCAST(L,1,MPI_INTEGER,0,mpi_comm_comp,irtn) if(grib=='grib2') then @@ -5998,7 +5847,7 @@ SUBROUTINE SURFCE ! print*,'Debug CMAQ: ',L,PINT(1,1,LM+1),PD(1,1),PINT(1,1,L) IF((PINT(1,1,LM+1)-PD(1,1))<=(PINT(1,1,L)+1.00))EXIT END DO -! PRINT*,'hybrid boundary ',L + PRINT*,'hybrid boundary ',L END IF CALL MPI_BCAST(L,1,MPI_INTEGER,0,mpi_comm_comp,irtn) if(grib=='grib2') then @@ -6061,7 +5910,6 @@ SUBROUTINE SURFCE endif ENDIF -<<<<<<< HEAD ! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR MASS REQUESTED FOR CMAQ @@ -6113,8 +5961,6 @@ SUBROUTINE SURFCE datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF -======= ->>>>>>> upstream/develop RETURN END diff --git a/sorc/ncep_post.fd/TIMEF.f b/sorc/ncep_post.fd/TIMEF.f index 84a7baaf8..e2cae9f44 100644 --- a/sorc/ncep_post.fd/TIMEF.f +++ b/sorc/ncep_post.fd/TIMEF.f @@ -1,13 +1,10 @@ ! function written early Dec. 1999 by M. Pyle to support workstation ! Eta for users with etime but not timef functionality (like certain !mp HPs) Designed to duplicate timef (elapsed time in milliseconds) -! -! mpi_wtime replaces etime, added by Jim Abeles ! function timef() use mpi implicit none -<<<<<<< HEAD real *8 et(2),rtc data et/0.0,0.0/ real*8 timef, etime @@ -16,14 +13,6 @@ function timef() timef=(et(2)-et(1)) ! timef=(et(2)-et(1))*1.e3 ! timef=mpi_wtime() *1.e3 -ti -======= - INCLUDE "mpif.h" - real et(2) - real*8 timef, etime -! timef=etime(et) -! timef=timef*1.e3 - timef=mpi_wtime() ->>>>>>> upstream/develop end function rtcfake() diff --git a/sorc/ncep_post.fd/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f index 909a25d96..a1c2f8bc3 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -143,8 +143,7 @@ PROGRAM WRFPOST lp1, lm1, im_jm, isf_surface_physics, nsoil, spl, lsmp1, global, & 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, & + fixed_tim, time_output, imin, surfce2_tim, komax, ivegsrc, d3d_on, gocart_on, & readxml_tim, spval, fullmodelname, submodelname, hyb_sigp, filenameflat use grib2_module, only: gribit2,num_pset,nrecout,first_grbtbl,grib_info_finalize use sigio_module, only: sigio_head @@ -163,7 +162,7 @@ PROGRAM WRFPOST ! !temporary vars ! - real(kind=8) :: time_initpost=0.,INITPOST_tim=0.,btim,bbtim + real(kind=8) :: time_initpost=0.,INITPOST_tim=0.,btim,timef real rinc(5), untcnvt integer :: status=0,iostatusD3D=0,iostatusFlux=0 integer i,j,iii,l,k,ierr,nrec,ist,lusig,idrt,ncid3d,varid @@ -175,7 +174,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 + ,hyb_sigp character startdate*19,SysDepInfo*80,IOWRFNAME*3,post_fname*255 character cgar*1,cdum*4,line*10 @@ -307,7 +306,6 @@ PROGRAM WRFPOST gocart_on = .false. popascal = .false. fileNameAER = '' - rdaod = .false. ! gocart_on = .true. ! d3d_on = .true. @@ -438,7 +436,6 @@ PROGRAM WRFPOST call ext_ncd_ioclose ( DataHandle, Status ) ELSE ! use netcdf lib directly to read FV3 output in netCDF - spval = 9.99e20 Status = nf90_open(trim(fileName),NF90_NOWRITE, ncid3d) if ( Status /= 0 ) then print*,'error opening ',fileName, ' Status = ', Status @@ -486,7 +483,6 @@ PROGRAM WRFPOST END IF ! use netcdf_parallel lib directly to read FV3 output in netCDF ELSE IF(TRIM(IOFORM) == 'netcdfpara') THEN - spval = 9.99e20 Status = nf90_open(trim(fileName),ior(nf90_nowrite, nf90_mpiio), & ncid3d, comm=mpi_comm_world, info=mpi_info_null) if ( Status /= 0 ) then @@ -734,8 +730,8 @@ PROGRAM WRFPOST CALL MPI_FIRST() - print*,'jsta,jend,jsta_m,jend_m,jsta_2l,jend_2u,spval=',jsta, & - jend,jsta_m,jend_m, jsta_2l,jend_2u,spval + print*,'jsta,jend,jsta_m,jend_m,jsta_2l,jend_2u=',jsta, & + jend,jsta_m,jend_m, jsta_2l,jend_2u CALL ALLOCATE_ALL() ! @@ -745,8 +741,7 @@ PROGRAM WRFPOST REWIND(LCNTRL) ! EXP. initialize netcdf here instead - bbtim = mpi_wtime() - btim = mpi_wtime() + btim = timef() ! set default novegtype if(MODELNAME == 'GFS')THEN novegtype = 13 @@ -773,19 +768,12 @@ PROGRAM WRFPOST CALL INITPOST_NMM ELSE IF (MODELNAME == 'FV3R') THEN ! use netcdf library to read output directly -<<<<<<< HEAD spval = 9.99e20 if(me .eq. 0) print*,' CALLING INITPOST_NETCDF' CALL INITPOST_NETCDF(ncid3d) ELSE IF (MODELNAME == 'GFS') THEN spval = 9.99e20 print*,' CALLING INITPOST_GFS_NETCDF' -======= - print*,'CALLING INITPOST_NETCDF' - CALL INITPOST_NETCDF(ncid3d) - ELSE IF (MODELNAME == 'GFS') THEN - print*,'CALLING INITPOST_GFS_NETCDF' ->>>>>>> upstream/develop CALL INITPOST_GFS_NETCDF(ncid3d) ELSE PRINT*,'POST does not have netcdf option for model,',MODELNAME,' STOPPING,' @@ -793,12 +781,8 @@ PROGRAM WRFPOST END IF ! use netcdf_parallel library to read fv3 output ELSE IF(TRIM(IOFORM) == 'netcdfpara') THEN -<<<<<<< HEAD spval = 9.99e20 print*,' CALLING INITPOST_GFS_NETCDF_PARA',timef() -======= - print*,'CALLING INITPOST_GFS_NETCDF_PARA' ->>>>>>> upstream/develop CALL INITPOST_GFS_NETCDF_PARA(ncid3d) ELSE IF(TRIM(IOFORM) == 'binarympiio') THEN IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR' .OR. MODELNAME == 'NMM') THEN @@ -860,7 +844,8 @@ PROGRAM WRFPOST PRINT*,'UNKNOWN MODEL OUTPUT FORMAT, STOPPING' STOP 9999 END IF - INITPOST_tim = INITPOST_tim +(mpi_wtime() - btim) + INITPOST_tim = INITPOST_tim +(timef() - btim) + time_initpost = time_initpost + timef() IF(ME == 0)THEN WRITE(6,*)'WRFPOST: INITIALIZED POST COMMON BLOCKS', time_initpost,initpost_tim ENDIF @@ -872,17 +857,11 @@ PROGRAM WRFPOST ! IF GRIB2 read out post aviable fields xml file and post control file ! if(grib == "grib2") then -<<<<<<< HEAD ! btim=timef() ta=timef() call READ_xml() READxml_tim = READxml_tim + (timef() - btim) if(me .eq. 0) print *,' readxml_tim', timef()-ta,timef() -======= - btim=mpi_wtime() - call READ_xml() - READxml_tim = READxml_tim + (mpi_wtime() - btim) ->>>>>>> upstream/develop endif ! ! LOOP OVER THE OUTPUT GRID(S). FIELD(S) AND OUTPUT GRID(S) ARE SPECIFIED @@ -1002,7 +981,6 @@ PROGRAM WRFPOST 1000 CONTINUE !exp call ext_ncd_ioclose ( DataHandle, Status ) ! -<<<<<<< HEAD if(me .eq. 0) then print*, 'INITPOST_tim = ', INITPOST_tim*1.0e-3 print*, 'MDLFLD_tim = ', ETAFLD2_tim*1.0e-3 @@ -1018,25 +996,6 @@ PROGRAM WRFPOST print*, 'Time for READxml = ',READxml_tim * 1.0e-3 endif -======= - IF(ME == 0) THEN - print*, 'INITPOST_tim = ', INITPOST_tim - print*, 'MDLFLD_tim = ', ETAFLD2_tim - print*, 'MDL2P_tim = ',ETA2P_tim - print*, 'MDL2SIGMA_tim = ',MDL2SIGMA_tim - print*, 'MDL2AGL_tim = ',MDL2AGL_tim - print*, 'SURFCE_tim = ',SURFCE2_tim - print*, 'CLDRAD_tim = ',CLDRAD_tim - print*, 'MISCLN_tim = ',MISCLN_tim - print*, 'MDL2STD_tim = ',MDL2STD_tim - print*, 'FIXED_tim = ',FIXED_tim - print*, 'MDL2THANDPV_tim = ',MDL2THANDPV_tim - print*, 'CALRAD_WCLOUD_tim = ',CALRAD_WCLOUD_tim - print*, 'Total time = ',(mpi_wtime() - bbtim) - print*, 'Time for OUTPUT = ',time_output - print*, 'Time for READxml = ',READxml_tim - endif ->>>>>>> upstream/develop ! ! END OF PROGRAM. ! @@ -1050,10 +1009,10 @@ PROGRAM WRFPOST ! ! ! -! call summary() - if (me == 0) CALL W3TAGE('UNIFIED_POST') + call summary() CALL MPI_FINALIZE(IERR) + CALL W3TAGE('UNIFIED_POST') STOP 0 diff --git a/sorc/ncep_post.fd/grib2_module.f b/sorc/ncep_post.fd/grib2_module.f index b944d84d8..b3cec8c64 100644 --- a/sorc/ncep_post.fd/grib2_module.f +++ b/sorc/ncep_post.fd/grib2_module.f @@ -208,6 +208,7 @@ subroutine gribit2(post_fname) character(255),intent(in) :: post_fname ! !------- local variables + real*8 timef,ta,tb,tc,td,te,tf,tg,th integer i,j,k,n,nm,nprm,nlvl,fldlvl1,fldlvl2,cstart,cgrblen,ierr integer nf,nfpe,nmod integer fh, clength,lunout @@ -354,8 +355,11 @@ subroutine gribit2(post_fname) allocate(datafldtmp(im_jm*nfld_pe(me+1)) ) allocate(datafld(im_jm,nfld_pe(me+1)) ) ! + ta=timef() call mpi_alltoallv(datapd,iscnt,isdsp,MPI_REAL, & datafldtmp,ircnt,irdsp,MPI_REAL,MPI_COMM_COMP,ierr) + tb=timef() + if(me .eq. 0) print *,' GWVX GRIBIT2 alltoall ',tb-ta ! !--- re-arrange the data datafld=0. @@ -409,8 +413,12 @@ subroutine gribit2(post_fname) ! !--- generate grib2 message --- ! + ta=timef() call gengrb2msg(idisc,icatg, iparm,nprm,nlvl,fldlvl1,fldlvl2,ntrange, & leng_time_range_stat,datafld(:,i),cgrib(cstart),clength) + tb=timef() + if(me .eq. 0) print 301,' GWVX GRIB2 WRITE ',tb-ta,timef() + 301 format(a25,2f10.3) cstart=cstart+clength ! else From 6d306b40e1d487f8deacf5631695eed52f3f1570 Mon Sep 17 00:00:00 2001 From: George Vandenberghe Date: Tue, 25 May 2021 18:08:38 +0000 Subject: [PATCH 08/77] fixed 5/25 problem --- sorc/ncep_post.fd/CLDRAD.f | 644 +++++++++------ sorc/ncep_post.fd/CTLBLK.f | 8 +- sorc/ncep_post.fd/MDL2AGL.f | 98 +-- sorc/ncep_post.fd/MDL2P.f | 441 ++++++----- sorc/ncep_post.fd/MDL2SIGMA.f | 106 +-- sorc/ncep_post.fd/MDL2SIGMA2.f | 15 +- sorc/ncep_post.fd/MDLFLD.f | 622 +++++++++------ sorc/ncep_post.fd/MISCLN.f | 1257 +++++++++++++++++++++++------- sorc/ncep_post.fd/MPI_FIRST.f | 21 +- sorc/ncep_post.fd/PARA_RANGE.f | 18 - sorc/ncep_post.fd/PROCESS.f | 29 +- sorc/ncep_post.fd/SURFCE.f | 726 +++++++++-------- sorc/ncep_post.fd/WRFPOST.f | 110 ++- sorc/ncep_post.fd/grib2_module.f | 8 - 14 files changed, 2508 insertions(+), 1595 deletions(-) diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index a8b54386d..749e4f3bf 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -70,6 +70,9 @@ !! 20-03-25 Jesse Meng - remove grib1 !! 20-05-20 Jesse Meng - CALRH unification with NAM scheme !! 20-11-10 Jesse Meng - USE UPP_PHYSICS MODULE +!! 21-02-08 Anning Cheng, read aod550, aod550_du/su/ss/oc/bc +!! directly from fv3gfs and output to grib2 by setting rdaod +!! 21-04-01 Jesse Meng - COMPUTATION ON DEFINED POINTS ONLY !! !! USAGE: CALL CLDRAD !! INPUT ARGUMENT LIST: @@ -114,7 +117,8 @@ SUBROUTINE CLDRAD SWDDIFC, SWUPBC, LWDNBC, LWUPBC, SWUPT, & TAOD5502D, AERSSA2D, AERASY2D, MEAN_FRP, LWP, IWP, & AVGCPRATE, & - DUSTCB,SSCB,BCCB,OCCB,SULFCB,DUSTPM,SSPM + DUSTCB,SSCB,BCCB,OCCB,SULFCB,DUSTPM,SSPM,aod550, & + du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550 use masks, only: LMH, HTM use params_mod, only: TFRZ, D00, H99999, QCLDMIN, SMALL, D608, H1, ROG, & GI, RD, QCONV, ABSCOEFI, ABSCOEF, STBOL, PQ0, A2, & @@ -123,7 +127,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,ista,iend + JM, LM, gocart_on, me, rdaod use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD use gridspec_mod, only: dyval, gridtype use cmassi_mod, only: TRAD_ice @@ -140,10 +144,10 @@ SUBROUTINE CLDRAD ! ! LOGICAL,dimension(im,jm) :: NEED INTEGER :: lcbot,lctop,jc,ic !bsf - INTEGER,dimension(ista:iend,jsta:jend) :: IBOTT, IBOTCu, IBOTDCu, IBOTSCu, IBOTGr, & + INTEGER,dimension(im,jsta:jend) :: IBOTT, IBOTCu, IBOTDCu, IBOTSCu, IBOTGr, & ITOPT, ITOPCu, ITOPDCu, ITOPSCu, ITOPGr REAL,dimension(im,jm) :: GRID1 - REAL,dimension(ista:iend,jsta:jend) :: GRID2, EGRID1, EGRID2, EGRID3, & + REAL,dimension(im,jsta:jend) :: GRID2, EGRID1, EGRID2, EGRID3, & CLDP, CLDZ, CLDT, CLDZCu REAL,dimension(lm) :: RHB, watericetotal, pabovesfc REAL :: watericemax, wimin, zcldbase, zcldtop, zpbltop, & @@ -156,9 +160,11 @@ SUBROUTINE CLDRAD real :: ceiling_thresh_cldfra, cldfra_max, & zceil, zceil1, zceil2, previous_sum, & ceil_min, ceil_neighbor + real,dimension(im,jm) :: ceil + ! B ZHOU: For aviation: - REAL, dimension(ista:iend,jsta:jend) :: TCLD, CEILING + REAL, dimension(im,jsta:jend) :: TCLD, CEILING real CU_ir(LM), q_conv !bsf !jw integer I,J,L,K,IBOT,ITCLOD,LBOT,LTOP,ITRDSW,ITRDLW, & @@ -168,8 +174,8 @@ SUBROUTINE CLDRAD ! real FULL_CLD(IM,JM) !-- Must be dimensioned for the full domain ! - real dummy(ista:iend,jsta:jend) - integer idummy(ista:iend,jsta:jend) + real dummy(IM,jsta:jend) + integer idummy(IM,jsta:jend) ! ! --- Revision added for GOCART --- @@ -214,7 +220,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(ista:iend,jsta:jend) :: P1D,T1D,Q1D,EGRID4 + REAL,dimension(im,jsta:jend) :: P1D,T1D,Q1D,EGRID4 ! REAL, allocatable :: RH3D(:,:,:) ! RELATIVE HUMIDITY real, allocatable:: rdrh(:,:,:) integer, allocatable :: ihh(:,:,:) @@ -222,10 +228,10 @@ SUBROUTINE CLDRAD INTEGER :: IH1, IH2 INTEGER :: IOS, INDX, ISSAM, ISSCM, ISUSO, IWASO, ISOOT, NBIN REAL :: CCDRY, CCWET, SSAM, SSCM - 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,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 :: ANG1, ANG2 INTEGER :: INDX_EXT(nAero), INDX_SCA(nAero) LOGICAL :: LAEROPT, LEXT, LSCA, LASY @@ -246,6 +252,7 @@ SUBROUTINE CLDRAD ! INDEX FOR TOTAL AND SPECIATED AEROSOLS (DU, SS, SU, OC, BC) data INDX_EXT / 610, 611, 612, 613, 614 / data INDX_SCA / 651, 652, 653, 654, 655 / + logical, parameter :: debugprint = .false. ! ! !************************************************************************* @@ -264,7 +271,7 @@ SUBROUTINE CLDRAD IF (IGET(030)>0.OR.IGET(572)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EGRID1(I,J) = SPVAL ENDDO ENDDO @@ -274,14 +281,14 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'RAPR') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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=ista,iend + DO I=1,IM IF(EGRID1(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) + TFRZ ENDDO ENDDO @@ -294,7 +301,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -309,7 +316,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im if (grid1(i,jj) /= spval) grid1(i,jj) = grid1(i,jj) - tfrz datapd(i,j,cfld) = GRID1(i,jj) enddo @@ -335,7 +342,7 @@ SUBROUTINE CLDRAD EGRID3,dummy,dummy) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(FIS(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -346,7 +353,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -363,7 +370,7 @@ SUBROUTINE CLDRAD IF ( (LVLS(1,IGET(032)) > 0) )THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(FIS(I,J) < SPVAL) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -377,7 +384,7 @@ SUBROUTINE CLDRAD EGRID3,dummy,dummy) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(FIS(I,J) < SPVAL) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -385,7 +392,7 @@ SUBROUTINE CLDRAD CALL BOUND(GRID1,D00,H99999) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(FIS(I,J) < SPVAL) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -395,7 +402,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -411,7 +418,7 @@ SUBROUTINE CLDRAD GRID1 = spval CALL CALPW(GRID1(1,jsta),1) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(FIS(I,J) >= SPVAL) GRID1(I,J)=spval END DO END DO @@ -422,7 +429,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -441,7 +448,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -460,7 +467,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -469,10 +476,12 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN CLOUD WATER IF (IGET(200) > 0 .or. IGET(575) > 0) THEN + GRID1 = spval + GRID2 = spval IF (MODELNAME == 'RAPR') THEN DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = LWP(I,J)/1000.0 ! use WRF-diagnosed value + DO I=1,IM + IF(LWP(I,J) < SPVAL) GRID1(I,J) = LWP(I,J)/1000.0 ! use WRF-diagnosed value ENDDO ENDDO ELSE @@ -482,8 +491,12 @@ SUBROUTINE CLDRAD CALL CALPW(GRID2(1,jsta),3) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(GRID1(I,J) 0) THEN + GRID1 = spval IF (MODELNAME == 'RAPR') THEN DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = IWP(I,J)/1000.0 ! use WRF-diagnosed value + DO I=1,IM + IF(IWP(I,J) < SPVAL) GRID1(I,J) = IWP(I,J)/1000.0 ! use WRF-diagnosed value ENDDO ENDDO ELSE @@ -537,7 +551,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -554,7 +568,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -571,7 +585,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -589,7 +603,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -607,7 +621,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -624,7 +638,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -641,7 +655,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -657,7 +671,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -673,7 +687,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -690,8 +704,8 @@ SUBROUTINE CLDRAD ENDIF !$omp parallel do DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = GRID1(I,J)*RRNUM + DO I=1,IM + IF(GRID1(I,J) < SPVAL) GRID1(I,J) = GRID1(I,J)*RRNUM ENDDO ENDDO ID(1:25)=0 @@ -723,7 +737,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -740,8 +754,8 @@ SUBROUTINE CLDRAD ENDIF !$omp parallel do DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = GRID1(I,J)*RRNUM + DO I=1,IM + IF(GRID1(I,J) < SPVAL) GRID1(I,J) = GRID1(I,J)*RRNUM ENDDO ENDDO ID(1:25)=0 @@ -773,7 +787,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -809,7 +823,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -819,7 +833,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=ista,iend + DO I=1,IM GRID1(I,J)=-5000. GRID2(I,J)=-5000. !-- Search for the base first, then look for the top if supercooled liquid exists @@ -859,7 +873,7 @@ SUBROUTINE CLDRAD IF (IGET(288)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=GRID2(I,J) ENDDO ENDDO @@ -869,7 +883,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -882,7 +896,7 @@ 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=ista,iend + DO I=1,IM GRID1(I,J) = CLDEFI(I,J) ENDDO ENDDO @@ -901,7 +915,7 @@ SUBROUTINE CLDRAD ! also a method for cloud ceiling height ! DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM CFRACL(I,J)=0. CFRACM(I,J)=0. CFRACH(I,J)=0. @@ -921,7 +935,7 @@ SUBROUTINE CLDRAD ! write (0,*) 'numr,dyval,DY_m=',numr,dyval,DY_m DO L=LM,1,-1 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(CFR(I,J,L)=PTOP_LOW) THEN @@ -1006,7 +1020,7 @@ SUBROUTINE CLDRAD IF (IGET(799)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=0.0 DO K = 1,LM IF (ZMID(I,J,LM-K+1) <= PBLH(I,J)+1000.0) THEN @@ -1026,7 +1040,7 @@ SUBROUTINE CLDRAD IF (IGET(037) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(CFRACL(I,J) < SPVAL) then GRID1(I,J) = CFRACL(I,J)*100. else @@ -1040,7 +1054,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1051,7 +1065,7 @@ SUBROUTINE CLDRAD IF (IGET(300) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(AVGCFRACL(I,J) < SPVAL) then GRID1(I,J) = AVGCFRACL(I,J)*100. else @@ -1090,7 +1104,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1102,7 +1116,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(CFRACM(I,J) < SPVAL) then GRID1(I,J) = CFRACM(I,J)*100. else @@ -1116,7 +1130,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1127,7 +1141,7 @@ SUBROUTINE CLDRAD IF (IGET(301) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ABS(AVGCFRACM(I,J)-SPVAL)>SMALL)THEN GRID1(I,J) = AVGCFRACM(I,J)*100. ELSE @@ -1166,7 +1180,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1178,7 +1192,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(CFRACH(I,J) < SPVAL) then GRID1(I,J) = CFRACH(I,J)*100. else @@ -1192,7 +1206,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1204,7 +1218,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(AVGCFRACH(I,J) < SPVAL) then GRID1(I,J) = AVGCFRACH(I,J)*100. else @@ -1243,7 +1257,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1256,7 +1270,7 @@ SUBROUTINE CLDRAD IF(MODELNAME=='NCAR' .OR. MODELNAME=='RAPR')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(i,j) = SPVAL egrid1(i,j)=0. do l = 1,LM @@ -1268,7 +1282,7 @@ SUBROUTINE CLDRAD ELSE IF (MODELNAME=='NMM'.OR.MODELNAME=='FV3R' & .OR. MODELNAME=='GFS')THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! 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))* & @@ -1280,7 +1294,7 @@ SUBROUTINE CLDRAD END IF !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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 @@ -1294,7 +1308,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1305,10 +1319,10 @@ SUBROUTINE CLDRAD ! TIME AVERAGED TOTAL CLOUD FRACTION. IF (IGET(144) > 0) THEN ! GRID1=SPVAL - IF(MODELNAME == 'GFS')THEN + IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ABS(AVGTCDC(I,J)-SPVAL) > SMALL) then GRID1(I,J) = AVGTCDC(I,J)*100. else @@ -1319,7 +1333,7 @@ SUBROUTINE CLDRAD ELSE IF(MODELNAME == 'NMM')THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! RSUM = NCFRST(I,J)+NCFRCV(I,J) ! IF (RSUM>0.0) THEN ! EGRID1(I,J)=(ACFRST(I,J)+ACFRCV(I,J))/RSUM @@ -1328,14 +1342,19 @@ SUBROUTINE CLDRAD ! ENDIF !ADDED BRAD'S MODIFICATION RSUM = D00 + IF (NCFRST(I,J) 0) RSUM=ACFRST(I,J)/NCFRST(I,J) IF (NCFRCV(I,J) > 0) & RSUM=MAX(RSUM, ACFRCV(I,J)/NCFRCV(I,J)) GRID1(I,J) = RSUM*100. + ELSE + GRID1(I,J) = spval + ENDIF ENDDO ENDDO END IF - IF(MODELNAME == 'NMM' .OR. MODELNAME == 'GFS')THEN + IF(MODELNAME == 'NMM' .OR. MODELNAME == 'GFS' .OR. & + MODELNAME == 'FV3R')THEN ID(1:25)= 0 ITCLOD = NINT(TCLOD) IF(ITCLOD /= 0) then @@ -1368,7 +1387,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1381,16 +1400,20 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF (NCFRST(I,J)0.0) THEN GRID1(I,J) = ACFRST(I,J)/NCFRST(I,J)*100. ELSE GRID1(I,J) = D00 ENDIF + ELSE + GRID1(I,J) = spval + ENDIF ENDDO ENDDO END IF - IF(MODELNAME=='NMM')THEN + IF(MODELNAME=='NMM' .or. MODELNAME=='FV3R')THEN ID(1:25)=0 ITCLOD = NINT(TCLOD) IF(ITCLOD /= 0) then @@ -1429,12 +1452,16 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF (NCFRCV(I,J)0.0) THEN GRID1(I,J) = ACFRCV(I,J)/NCFRCV(I,J)*100. ELSE GRID1(I,J) = D00 ENDIF + ELSE + GRID1(I,J) = spval + ENDIF ENDDO ENDDO END IF @@ -1485,7 +1512,7 @@ SUBROUTINE CLDRAD !--- Rain is not part of cloud, only cloud water + cloud ice + snow ! DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! !--- Various convective cloud base & cloud top levels ! @@ -1616,7 +1643,7 @@ SUBROUTINE CLDRAD IF (IGET(758)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDZCu(I,J) ENDDO ENDDO @@ -1635,7 +1662,7 @@ SUBROUTINE CLDRAD ! IF ((IGET(148)>0) .OR. (IGET(178)>0) .OR.(IGET(260)>0) ) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IBOT=IBOTT(I,J) !-- Cloud base ("bottoms") IF(MODELNAME == 'RAPR') then IF (IBOT <= 0) THEN @@ -1666,7 +1693,7 @@ SUBROUTINE CLDRAD ! CLOUD BOTTOM PRESSURE IF (IGET(148)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -1680,7 +1707,7 @@ SUBROUTINE CLDRAD IF (IGET(178)>0) THEN !--- Parameter was set to 148 in operational code (Ferrier, Feb '02) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -1719,7 +1746,7 @@ SUBROUTINE CLDRAD DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! !- imported from RUC post IF(MODELNAME == 'RAPR') then @@ -1911,7 +1938,7 @@ SUBROUTINE CLDRAD nlifr = 0 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM zcld = CLDZ(i,j) - FIS(I,J)*GI if (CLDZ(i,j)>=0..and.zcld<160.) nlifr = nlifr+1 end do @@ -1920,9 +1947,9 @@ SUBROUTINE CLDRAD ! GSD CLOUD BOTTOM HEIGHTS IF (IGET(408)>0) THEN -!$omp parallel do private(i,j) +!!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -1946,7 +1973,7 @@ SUBROUTINE CLDRAD ceiling_thresh_cldfra = 0.5 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ceil(I,J) = SPVAL zceil = SPVAL cldfra_max = 0. @@ -2017,7 +2044,7 @@ SUBROUTINE CLDRAD ! proceed to gridding DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ceil(I,J) ENDDO ENDDO @@ -2047,7 +2074,7 @@ SUBROUTINE CLDRAD const1 = 3.912 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ceil(I,J) = SPVAL zceil = SPVAL zceil1 = SPVAL @@ -2165,7 +2192,7 @@ SUBROUTINE CLDRAD ! layer. numr = 1 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ceil_min = max( ceil(I,J)-FIS(I,J)*GI , 5.0) ! ceil_min in AGL do jc = max(JSTA,J-numr),min(JEND,J+numr) do ic = max(1,I-numr),min(IM,I+numr) @@ -2176,7 +2203,7 @@ SUBROUTINE CLDRAD CLDZ(I,J) = ceil_min + FIS(I,J)*GI ! convert back to ASL and store CLDZ(I,J) = max(min(CLDZ(I,J), 20000.0),0.0) !set bounds ! find pressure at CLDZ - do k=1,lm-2 + do k=2,lm-2 if ( zmid(i,j,lm-k+1) >= CLDZ(i,j) ) then CLDP(I,J) = pmid(i,j,lm-k+2) + (CLDZ(i,j)-zmid(i,j,lm-k+2)) & *(pmid(i,j,lm-k+1)-pmid(i,j,lm-k+2) ) & @@ -2189,9 +2216,9 @@ SUBROUTINE CLDRAD ! GSD CLOUD BOTTOM HEIGHT IF (IGET(711)>0) THEN -!$omp parallel do private(i,j) +!!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -2204,9 +2231,9 @@ SUBROUTINE CLDRAD ! GSD CLOUD BOTTOM PRESSURE IF (IGET(798)>0) THEN -!$omp parallel do private(i,j) +!!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -2224,7 +2251,7 @@ SUBROUTINE CLDRAD IF (IGET(260)>0) THEN CALL CALCEILING(CLDZ,TCLD,CEILING) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CEILING(I,J) ENDDO ENDDO @@ -2238,7 +2265,7 @@ SUBROUTINE CLDRAD IF (IGET(261) > 0) THEN CALL CALFLTCND(CEILING,GRID1(1,jsta)) ! DO J=JSTA,JEND -! DO I=ista,iend +! DO I=1,IM ! GRID1(I,J) = FLTCND(I,J) ! ENDDO ! ENDDO @@ -2248,7 +2275,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2261,13 +2288,13 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PBOT(I,J) ENDDO ENDDO ELSE DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IBOT=IBOTCu(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2283,7 +2310,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2294,7 +2321,7 @@ SUBROUTINE CLDRAD ! IF (IGET(192) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IBOT=IBOTDCu(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2313,7 +2340,7 @@ SUBROUTINE CLDRAD ! IF (IGET(190) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IBOT=IBOTSCu(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2332,7 +2359,7 @@ SUBROUTINE CLDRAD ! IF (IGET(194) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IBOT=IBOTGr(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2352,7 +2379,7 @@ SUBROUTINE CLDRAD ! IF (IGET(303) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! IF(PBOTL(I,J) > SMALL)THEN GRID1(I,J) = PBOTL(I,J) ! ELSE @@ -2395,7 +2422,7 @@ SUBROUTINE CLDRAD ! IF (IGET(306) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(PBOTM(I,J) > SMALL)THEN GRID1(I,J) = PBOTM(I,J) ELSE @@ -2438,7 +2465,7 @@ SUBROUTINE CLDRAD ! IF (IGET(309) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(PBOTH(I,J) > SMALL)THEN GRID1(I,J) = PBOTH(I,J) ELSE @@ -2487,7 +2514,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=ista,iend + DO I=1,IM 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=ista,iend + DO I=1,IM GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -2537,7 +2564,7 @@ SUBROUTINE CLDRAD ! IF (IGET(179)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -2555,7 +2582,7 @@ SUBROUTINE CLDRAD Cloud_def_p = 0.0000001 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! imported from RUC post ! Cloud top zcldtop = -5000. @@ -2619,7 +2646,7 @@ SUBROUTINE CLDRAD ! IF (IGET(406)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDP(I,J) ENDDO ENDDO @@ -2633,7 +2660,7 @@ SUBROUTINE CLDRAD ! IF (IGET(409)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO @@ -2649,7 +2676,7 @@ SUBROUTINE CLDRAD ! IF (IGET(168)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CLDT(I,J) ENDDO ENDDO @@ -2665,7 +2692,7 @@ SUBROUTINE CLDRAD num_thick=0 ! for debug GRID1=spval DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM opdepth=0. llmh=nint(lmh(i,j)) !bsf - start @@ -2765,13 +2792,13 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PTOP(I,J) ENDDO ENDDO ELSE DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ITOP=ITOPCu(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2787,7 +2814,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2798,7 +2825,7 @@ SUBROUTINE CLDRAD ! IF (IGET(193) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ITOP=ITOPDCu(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2817,7 +2844,7 @@ SUBROUTINE CLDRAD ! IF (IGET(191) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ITOP=ITOPSCu(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2837,7 +2864,7 @@ SUBROUTINE CLDRAD ! IF (IGET(195) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ITOP=ITOPGr(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2857,7 +2884,7 @@ SUBROUTINE CLDRAD ! IF (IGET(304) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(PTOPL(I,J) > SMALL)THEN GRID1(I,J) = PTOPL(I,J) ELSE @@ -2900,7 +2927,7 @@ SUBROUTINE CLDRAD ! IF (IGET(307) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PTOPM(I,J) ENDDO ENDDO @@ -2939,7 +2966,7 @@ SUBROUTINE CLDRAD ! IF (IGET(310) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PTOPH(I,J) ENDDO ENDDO @@ -2979,7 +3006,7 @@ SUBROUTINE CLDRAD ! IF (IGET(305) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = TTOPL(I,J) ENDDO ENDDO @@ -3018,7 +3045,7 @@ SUBROUTINE CLDRAD ! IF (IGET(308) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = TTOPM(I,J) ENDDO ENDDO @@ -3057,7 +3084,7 @@ SUBROUTINE CLDRAD ! IF (IGET(311) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = TTOPH(I,J) ENDDO ENDDO @@ -3097,7 +3124,7 @@ SUBROUTINE CLDRAD IF (IGET(196) > 0.or.IGET(570)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(CNVCFR(I,J)/=SPVAL)GRID1(I,J)=100.*CNVCFR(I,J) !-- convert to percent ENDDO ENDDO @@ -3121,7 +3148,7 @@ SUBROUTINE CLDRAD IF (IGET(342) > 0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(PBLCFR(I,J)/=SPVAL)GRID1(I,J)=100.*PBLCFR(I,J) !-- convert to percent ENDDO ENDDO @@ -3161,7 +3188,7 @@ SUBROUTINE CLDRAD ! IF (IGET(313) > 0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=cldwork(I,J) ENDDO ENDDO @@ -3213,7 +3240,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ASWIN(I,J)/=SPVAL)THEN GRID1(I,J) = ASWIN(I,J)*RRNUM ELSE @@ -3266,7 +3293,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(AUVBIN(I,J)/=SPVAL)THEN GRID1(I,J) = AUVBIN(I,J)*RRNUM ELSE @@ -3320,7 +3347,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(AUVBINC(I,J)/=SPVAL)THEN GRID1(I,J) = AUVBINC(I,J)*RRNUM ELSE @@ -3373,7 +3400,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ALWIN(I,J)/=SPVAL)THEN GRID1(I,J) = ALWIN(I,J)*RRNUM ELSE @@ -3425,7 +3452,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ASWOUT(I,J)/=SPVAL)THEN GRID1(I,J) = -1.0*ASWOUT(I,J)*RRNUM ELSE @@ -3477,7 +3504,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ALWOUT(I,J)/=SPVAL)THEN GRID1(I,J) = -1.0*ALWOUT(I,J)*RRNUM ELSE @@ -3529,7 +3556,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ASWTOA(I,J)/=SPVAL)THEN GRID1(I,J) = ASWTOA(I,J)*RRNUM ELSE @@ -3581,7 +3608,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ALWTOA(I,J)/=SPVAL)THEN GRID1(I,J) = ALWTOA(I,J)*RRNUM ELSE @@ -3627,7 +3654,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RLWTOA(I,J) ENDDO ENDDO @@ -3646,7 +3673,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(RLWTOA(I,J) < SPVAL) & & GRID1(I,J) = (RLWTOA(I,J)*STBOL)**0.25 ENDDO @@ -3661,14 +3688,17 @@ SUBROUTINE CLDRAD ! ! CURRENT INCOMING SW RADIATION AT THE SURFACE. IF (IGET(156)>0) THEN + GRID1=SPVAL DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(RSWIN(I,J)1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE FACTRS=0.0 ENDIF - GRID1(I,J)=RSWIN(I,J)*FACTRS + IF(RSWIN(I,J)0.0) THEN LLMH=NINT(LMH(I,J)) TLMH=T(I,J,LLMH) @@ -3696,6 +3727,7 @@ SUBROUTINE CLDRAD FACTRL=0.0 ENDIF IF(RLWIN(I,J) < spval) GRID1(I,J)=RLWIN(I,J)*FACTRL + ENDIF ENDIF ENDDO ENDDO @@ -3709,15 +3741,18 @@ SUBROUTINE CLDRAD ! ! CURRENT OUTGOING SW RADIATION AT THE SURFACE. IF (IGET(141)>0) THEN + GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(RSWOUT(I,J)1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE FACTRS=0.0 ENDIF - GRID1(I,J)=RSWOUT(I,J)*FACTRS + IF(RSWOUT(I,J)0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWUPBC(I,J) ENDDO ENDDO @@ -3746,7 +3781,7 @@ SUBROUTINE CLDRAD IF (IGET(142)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RADOT(I,J) ENDDO ENDDO @@ -3760,7 +3795,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky downwelling LW at the surface IF (IGET(744)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = LWDNBC(I,J) ENDDO ENDDO @@ -3774,7 +3809,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky upwelling LW at the surface IF (IGET(745)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = LWUPBC(I,J) ENDDO ENDDO @@ -3787,14 +3822,14 @@ SUBROUTINE CLDRAD ! Instantaneous MEAN_FRP IF (IGET(740)>0) THEN - print *,"GETTING INTO MEAN_FRP PART" +! print *,"GETTING INTO MEAN_FRP PART" DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = MEAN_FRP(I,J) ENDDO ENDDO if(grib=='grib2') then - print *,"GETTING INTO MEAN_FRP GRIB2 PART" +! 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) @@ -3803,15 +3838,18 @@ SUBROUTINE CLDRAD ! CURRENT (instantaneous) INCOMING CLEARSKY SW RADIATION AT THE SURFACE. IF (IGET(262)>0) THEN + GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(RSWINC(I,J)1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) ELSE FACTRS=0.0 ENDIF - GRID1(I,J) = RSWINC(I,J)*FACTRS + IF(RSWINC(I,J)0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWDNBC(I,J) ENDDO ENDDO @@ -3839,7 +3877,7 @@ SUBROUTINE CLDRAD IF (IGET(772)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWDDNI(I,J) ENDDO ENDDO @@ -3853,7 +3891,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky SWDDNI IF (IGET(796)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWDDNIC(I,J) ENDDO ENDDO @@ -3868,7 +3906,7 @@ SUBROUTINE CLDRAD IF (IGET(773)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWDDIF(I,J) ENDDO ENDDO @@ -3882,7 +3920,7 @@ SUBROUTINE CLDRAD ! Instantaneous clear-sky SWDDIF IF (IGET(797)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWDDIFC(I,J) ENDDO ENDDO @@ -3896,7 +3934,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED INCOMING CLEARSKY SW RADIATION AT THE SURFACE. IF (IGET(383)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ASWINC(I,J) ENDDO ENDDO @@ -3934,7 +3972,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY SW RADIATION AT THE SURFACE. IF (IGET(386)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ASWOUTC(I,J) ENDDO ENDDO @@ -3972,7 +4010,7 @@ SUBROUTINE CLDRAD ! Instantaneous all-sky outgoing SW flux at the model top IF (IGET(719)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SWUPT(I,J) ENDDO ENDDO @@ -3986,7 +4024,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY SW RADIATION AT THE MODEL TOP IF (IGET(387)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ASWTOAC(I,J) ENDDO ENDDO @@ -4024,7 +4062,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED INCOMING SW RADIATION AT THE MODEL TOP IF (IGET(388)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ASWINTOA(I,J) ENDDO ENDDO @@ -4062,7 +4100,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED INCOMING CLEARSKY LW RADIATION AT THE SURFACE IF (IGET(382)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ALWINC(I,J) ENDDO ENDDO @@ -4100,7 +4138,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY LW RADIATION AT THE SURFACE IF (IGET(384)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ALWOUTC(I,J) ENDDO ENDDO @@ -4138,7 +4176,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED OUTGOING CLEARSKY LW RADIATION AT THE MODEL TOP IF (IGET(385)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ALWTOAC(I,J) ENDDO ENDDO @@ -4176,7 +4214,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE BEAM DOWNWARD SOLAR FLUX IF (IGET(401)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = AVISBEAMSWIN(I,J) ENDDO ENDDO @@ -4216,7 +4254,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE DIFFUSE DOWNWARD SOLAR FLUX IF (IGET(402)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = AVISDIFFSWIN(I,J) ENDDO ENDDO @@ -4255,7 +4293,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE BEAM DOWNWARD SOLAR FLUX IF (IGET(403)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = AIRBEAMSWIN(I,J) ENDDO ENDDO @@ -4294,7 +4332,7 @@ SUBROUTINE CLDRAD ! TIME AVERAGED SURFACE VISIBLE DIFFUSE DOWNWARD SOLAR FLUX IF (IGET(404)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = AIRDIFFSWIN(I,J) ENDDO ENDDO @@ -4330,10 +4368,92 @@ SUBROUTINE CLDRAD endif ENDIF + !2D AEROSOL OPTICAL DEPTH AT 550 NM + IF(rdaod) then + IF (IGET(609).GT.0) THEN + DO J=JSTA,JEND + DO I=1,IM + 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) + endif + ENDIF + + IF (IGET(610).GT.0) THEN + DO J=JSTA,JEND + DO I=1,IM + 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) + endif + ENDIF + + IF (IGET(611).GT.0) THEN + DO J=JSTA,JEND + DO I=1,IM + 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) + endif + ENDIF + + IF (IGET(612).GT.0) THEN + DO J=JSTA,JEND + DO I=1,IM + 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) + endif + ENDIF + + IF (IGET(613).GT.0) THEN + DO J=JSTA,JEND + DO I=1,IM + 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) + endif + ENDIF + + + IF (IGET(614).GT.0) THEN + DO J=JSTA,JEND + DO I=1,IM + 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) + endif + ENDIF + END IF !rdaod + !2D AEROSOL OPTICAL DEPTH AT 550 NM IF (IGET(715)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM grid1(i,j)=taod5502d(i,j) ENDDO ENDDO @@ -4347,7 +4467,7 @@ SUBROUTINE CLDRAD !AEROSOL ASYMMETRY FACTOR IF (IGET(716)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM grid1(i,j)=aerasy2d(i,j) ENDDO ENDDO @@ -4361,7 +4481,7 @@ SUBROUTINE CLDRAD !AEROSOL SINGLE-SCATTERING ALBEDO IF (IGET(717)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM grid1(i,j)=aerssa2d(i,j) ENDDO ENDDO @@ -4402,6 +4522,10 @@ SUBROUTINE CLDRAD DO I = 690, 698 ! TOTAL AND SPECIATED AEROSOL IF ( IGET(I)>0 ) LAERSMASS = .TRUE. ENDDO + IF ( rdaod ) THEN + LAEROPT = .FALSE. + LAERSMASS = .FALSE. + END IF IF ( LAEROPT ) THEN PRINT *, 'COMPUTE AEROSOL OPTICAL PROPERTIES' @@ -4443,7 +4567,7 @@ SUBROUTINE CLDRAD print *,' ERROR! Non-zero iostat for rd_LUTS ', aerosol_file stop ENDIF - print *,'i=',i,'read aerosol_file=',trim(aerosol_file),'ios=',ios + if(debugprint)print *,'i=',i,'read aerosol_file=',trim(aerosol_file),'ios=',ios ! IF (AerosolName(i) == 'DUST') nbin = nbin_du IF (AerosolName(i) == 'SALT') nbin = nbin_ss @@ -4545,19 +4669,19 @@ SUBROUTINE CLDRAD ENDDO ! j-loop for nbin ENDDO ! i-loop for nAero - print *,'finish reading coef' +! print *,'finish reading coef' CLOSE(UNIT=NOAER) !!! COMPUTES RELATIVE HUMIDITY AND RDRH ! allocate (RH3D(im,jsta:jend,lm)) - allocate (rdrh(ista:iend,jsta:jend,lm)) - allocate (ihh(ista:iend,jsta:jend,lm)) + allocate (rdrh(im,jsta:jend,lm)) + allocate (ihh(im,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=ista,iend + DO I=1,IM P1D(I,J) = PMID(I,J,LL) T1D(I,J) = T(I,J,LL) Q1D(I,J) = Q(I,J,LL) @@ -4565,7 +4689,7 @@ SUBROUTINE CLDRAD ENDDO CALL CALRH(P1D,T1D,Q1D,EGRID4) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! RH3D(I,J,LL) = EGRID4(I,J) RH3D = EGRID4(I,J) ! DETERMINE RDRH (wgt for IH2) and IHH (index for IH2) @@ -4642,7 +4766,7 @@ SUBROUTINE CLDRAD IF ( IB == 2 ) LEXT = .TRUE. IF ( IB == 5 ) LEXT = .TRUE. ENDIF - print *,'LEXT=',LEXT,'LSCA=',LSCA,'LASY=',LASY +! print *,'LEXT=',LEXT,'LSCA=',LSCA,'LASY=',LASY ! SKIP IF POST PRODUCT IS NOT REQUESTED IF ( LEXT .OR. LSCA .OR. LASY ) THEN ! COMPUTE DUST AOD @@ -4653,7 +4777,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM DO L=1,LM DO N=1, NBIN_DU EXT01 = EXTRHD_DU(1,N,IB) @@ -4680,7 +4804,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM DO L=1,LM ih1 = ihh(I,J,L) ih2 = ih1 + 1 @@ -4714,7 +4838,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4747,7 +4871,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4779,7 +4903,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4809,7 +4933,7 @@ SUBROUTINE CLDRAD SCA=SPVAL ASY=SPVAL DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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) @@ -4841,7 +4965,7 @@ SUBROUTINE CLDRAD IF (IB == 2 ) THEN !! AOD AT 440 NM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM AOD_440(I,J) = AOD(I,J) ENDDO ! I-loop ENDDO ! J-loop @@ -4850,7 +4974,7 @@ SUBROUTINE CLDRAD IF (IB == 5 ) THEN !! AOD AT 860 NM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM AOD_860(I,J) = AOD(I,J) ENDDO ! I-loop ENDDO ! J-loop @@ -4861,7 +4985,7 @@ SUBROUTINE CLDRAD IF ( IGET(INDX) > 0) THEN !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im GRID1(i,j) = AOD(i,j) enddo enddo @@ -4878,15 +5002,18 @@ SUBROUTINE CLDRAD ! AER ASYM FACTOR AT 340 NM IF ( IGET(649) > 0 ) THEN + GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(SCA2D(I,J) 0.0 ) THEN ASY2D(I,J) = ASY2D(I,J) / SCA2D(I,J) ELSE ASY2D(I,J) = 0. ENDIF - GRID1(I,J)=ASY2D(I,J) + IF(ASY2D(I,J) 0 ) THEN + GRID1 = SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(AOD(I,J) 0.0 ) THEN SCA2D(I,J) = SCA2D(I,J) / AOD(I,J) ELSE SCA2D(I,J) = 1.0 ENDIF - GRID1(I,J)=SCA2D(I,J) + IF(SCA2D(I,J) 0 ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=SCA2D(I,J) ENDDO ENDDO @@ -4949,7 +5079,7 @@ SUBROUTINE CLDRAD IF ( IGET(JJ) > 0) THEN ! EXT AOD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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) @@ -4970,7 +5100,7 @@ SUBROUTINE CLDRAD IF ( IGET(JJ) > 0) THEN ! SCA AOD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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) @@ -4999,7 +5129,7 @@ SUBROUTINE CLDRAD ANG2 = LOG ( 860. / 440. ) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF (AOD_860(I,J) > 0.) THEN ANG1 = LOG( AOD_440(I,J)/AOD_860(I,J) ) ANGST(I,J) = ANG1 / ANG2 @@ -5007,7 +5137,7 @@ SUBROUTINE CLDRAD GRID1(I,J)=ANGST(I,J) ENDDO ENDDO - print *,'output angstrom exp,angst=',maxval(angst(1:im,jsta:jend)), & + if(debugprint)print *,'output angstrom exp,angst=',maxval(angst(1:im,jsta:jend)), & minval(angst(1:im,jsta:jend)) CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then @@ -5024,9 +5154,10 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend - GRID1(I,J) = DUEM(I,J,1)*1.E-6 + DO I = 1,IM + IF(DUEM(I,J,1)0) THEN ! DO J = JSTA,JEND -! DO I = ista,iend +! DO I = 1,IM ! 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 @@ -5069,7 +5201,7 @@ SUBROUTINE CLDRAD ! ID(1:25) = 0 ! ID(02)=141 ! if(grib=='grib1') then -! CALL GRIBIT(IGET(661),LVLS(1,IGET(661)),GRIDista,iend,JM) +! CALL GRIBIT(IGET(661),LVLS(1,IGET(661)),GRID1,IM,JM) ! elseif(grib=='grib2') then ! cfld=cfld+1 ! fld_info(cfld)%ifld=IAVBLFLD(IGET(661)) @@ -5081,7 +5213,7 @@ SUBROUTINE CLDRAD IF (IGET(686)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend + DO I = 1,IM !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = DUSTPM(I,J) !ug/m3 END DO @@ -5096,7 +5228,7 @@ SUBROUTINE CLDRAD !! ADD DUST WET DEPOSITION FLUXES (kg/m2/sec) ! IF (IGET(662)>0) THEN ! DO J = JSTA,JEND -! DO I = ista,iend +! DO I = 1,IM ! 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 @@ -5106,7 +5238,7 @@ SUBROUTINE CLDRAD ! ID(1:25) = 0 ! ID(02)=141 ! if(grib=='grib1') then -! CALL GRIBIT(IGET(662),LVLS(1,IGET(662)),GRIDista,iend,JM) +! CALL GRIBIT(IGET(662),LVLS(1,IGET(662)),GRID1,IM,JM) ! elseif(grib=='grib2') then ! cfld=cfld+1 ! fld_info(cfld)%ifld=IAVBLFLD(IGET(662)) @@ -5118,7 +5250,7 @@ SUBROUTINE CLDRAD IF (IGET(684)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend + DO I = 1,IM !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = SSPM(I,J) !ug/m3 END DO @@ -5133,7 +5265,7 @@ SUBROUTINE CLDRAD IF (IGET(619)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend + DO I = 1,IM !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = DUSMASS(I,J) !ug/m3 END DO @@ -5149,7 +5281,7 @@ SUBROUTINE CLDRAD IF (IGET(620)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend + DO I = 1,IM !GRID1(I,J) = DUSMASS25(I,J) * 1.E-6 GRID1(I,J) = DUSMASS25(I,J) ! ug/m3 END DO @@ -5162,11 +5294,12 @@ SUBROUTINE CLDRAD ENDIF !! ADD TOTAL AEROSOL PM10 COLUMN DENSITY (kg/m2) ! IF (IGET(621)>0 ) THEN + GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend + DO I = 1,IM !GRID1(I,J) = DUCMASS(I,J) * 1.E-6 - GRID1(I,J) = DUCMASS(I,J) * 1.E-9 + IF(DUCMASS(I,J)0 ) THEN + GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend + DO I = 1,IM !GRID1(I,J) = DUCMASS25(I,J) * 1.E-6 - GRID1(I,J) = DUCMASS25(I,J) * 1.E-9 + IF(DUCMASS25(I,J)0 ) THEN + GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend - GRID1(I,J) = DUSTCB(I,J) * 1.E-9 + DO I = 1,IM + IF(DUSTCB(I,J)0 ) THEN + GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend - GRID1(I,J) = SSCB(I,J) * 1.E-9 + DO I = 1,IM + IF(SSCB(I,J)0 ) THEN + GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend - GRID1(I,J) = BCCB(I,J) * 1.E-9 + DO I = 1,IM + IF(BCCB(I,J)0 ) THEN + GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend - GRID1(I,J) = OCCB(I,J) * 1.E-9 + DO I = 1,IM + IF(OCCB(I,J)0 ) THEN + GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend - GRID1(I,J) = SULFCB(I,J) * 1.E-9 + DO I = 1,IM + IF(SULFCB(I,J)0) call wrt_aero_diag(659,nbin_du,duem) - print *,'aft wrt disg duem' +! print *,'aft wrt disg duem' IF (IGET(660)>0) call wrt_aero_diag(660,nbin_du,dusd) IF (IGET(661)>0) call wrt_aero_diag(661,nbin_du,dudp) IF (IGET(662)>0) call wrt_aero_diag(662,nbin_du,duwt) IF (IGET(679)>0) call wrt_aero_diag(679,nbin_du,dusv) - print *,'aft wrt disg duwt' +! print *,'aft wrt disg duwt' !! wrt SS diag field IF (IGET(663)>0) call wrt_aero_diag(663,nbin_ss,ssem) @@ -5282,7 +5421,7 @@ SUBROUTINE CLDRAD IF (IGET(665)>0) call wrt_aero_diag(665,nbin_ss,ssdp) IF (IGET(666)>0) call wrt_aero_diag(666,nbin_ss,sswt) IF (IGET(680)>0) call wrt_aero_diag(680,nbin_ss,sssv) - print *,'aft wrt disg sswt' +! print *,'aft wrt disg sswt' !! wrt BC diag field IF (IGET(667)>0) call wrt_aero_diag(667,nbin_bc,bcem) @@ -5290,7 +5429,7 @@ SUBROUTINE CLDRAD IF (IGET(669)>0) call wrt_aero_diag(669,nbin_bc,bcdp) IF (IGET(670)>0) call wrt_aero_diag(670,nbin_bc,bcwt) IF (IGET(681)>0) call wrt_aero_diag(681,nbin_bc,bcsv) - print *,'aft wrt disg bcwt' +! print *,'aft wrt disg bcwt' !! wrt OC diag field IF (IGET(671)>0) call wrt_aero_diag(671,nbin_oc,ocem) @@ -5298,7 +5437,7 @@ SUBROUTINE CLDRAD IF (IGET(673)>0) call wrt_aero_diag(673,nbin_oc,ocdp) IF (IGET(674)>0) call wrt_aero_diag(674,nbin_oc,ocwt) IF (IGET(682)>0) call wrt_aero_diag(682,nbin_oc,ocsv) - print *,'aft wrt disg ocwt' +! print *,'aft wrt disg ocwt' !! wrt SU diag field ! IF (IGET(675)>0) call wrt_aero_diag(675,nbin_su,suem) @@ -5313,7 +5452,7 @@ SUBROUTINE CLDRAD ! CB cover is derived from CPRAT (same as #272 in SURFCE.f) EGRID1 = SPVAL DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(AVGCPRATE(I,J) /= SPVAL) then EGRID1(I,J) = AVGCPRATE(I,J)*(1000./DTQ2) end if @@ -5327,7 +5466,7 @@ SUBROUTINE CLDRAD EGRID3 = SPVAL IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') then DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EGRID2(I,J) = PBOT(I,J) EGRID3(I,J) = PTOP(I,J) END DO @@ -5336,7 +5475,7 @@ SUBROUTINE CLDRAD ! Derive CB base and top, relationship among CB fields DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(EGRID1(I,J)<= 0. .or. EGRID2(I,J)<= 0. .or. EGRID3(I,J) <= 0.) then EGRID1(I,J) = SPVAL EGRID2(I,J) = SPVAL @@ -5345,7 +5484,7 @@ SUBROUTINE CLDRAD END DO END DO DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(EGRID2(I,J) == SPVAL .or. EGRID3(I,J) == SPVAL) cycle if(EGRID3(I,J) < 400.*100. .and. & (EGRID2(I,J)-EGRID3(I,J)) > 300.*100) then @@ -5394,7 +5533,7 @@ SUBROUTINE CLDRAD IF(IGET(473) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -5403,7 +5542,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5412,7 +5551,7 @@ SUBROUTINE CLDRAD IF(IGET(474) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = EGRID2(I,J) ENDDO ENDDO @@ -5421,7 +5560,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5430,7 +5569,7 @@ SUBROUTINE CLDRAD IF(IGET(475) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -5439,7 +5578,7 @@ SUBROUTINE CLDRAD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5456,7 +5595,7 @@ 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,ista,iend + use ctlblk_mod, only: SPVAL,JSTA,JEND,IM implicit none real, intent(inout) :: cbcov(IM,JSTA:JEND) @@ -5509,7 +5648,7 @@ 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,ista,iend + cfld, datapd, fld_info, jsta_2l, jend_2u use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD implicit none ! @@ -5522,9 +5661,10 @@ subroutine wrt_aero_diag(igetfld,nbin,data) GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = ista,iend - grid1(I,J) = data(I,J,1) + DO I = 1,IM + if(data(I,J,1)0) )THEN if(MODELNAME=='RAPR') then DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=DBZ1LOG(I,J) ENDDO ENDDO else DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=DBZ1(I,J) ENDDO ENDDO @@ -297,7 +298,7 @@ SUBROUTINE MDL2AGL !--- Radar reflectivity from rain IF((IGET(279)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=DBZR1(I,J) ENDDO ENDDO @@ -311,7 +312,7 @@ SUBROUTINE MDL2AGL !--- Radar reflectivity from all ice habits (snow + graupel + sleet, etc.) IF((IGET(280)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=DBZI1(I,J) ENDDO ENDDO @@ -325,7 +326,7 @@ SUBROUTINE MDL2AGL !--- Radar reflectivity from parameterized convection IF((IGET(281)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=DBZC1(I,J) ENDDO ENDDO @@ -350,7 +351,7 @@ SUBROUTINE MDL2AGL !--- Max Derived Radar Reflectivity IF((IGET(421)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=REFD_MAX(I,J) ENDDO ENDDO @@ -372,7 +373,7 @@ SUBROUTINE MDL2AGL !--- Max Derived Radar Reflectivity at -10C IF((IGET(785)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=REFDM10C_MAX(I,J) ENDDO ENDDO @@ -393,7 +394,7 @@ SUBROUTINE MDL2AGL !--- Max Updraft Helicity IF((IGET(420)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=UP_HELI_MAX(I,J) ENDDO ENDDO @@ -414,7 +415,7 @@ SUBROUTINE MDL2AGL !--- Max Updraft Helicity 1-6 km IF((IGET(700)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=UP_HELI_MAX16(I,J) ENDDO ENDDO @@ -435,7 +436,7 @@ SUBROUTINE MDL2AGL !--- Min Updraft Helicity IF((IGET(786)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=UP_HELI_MIN(I,J) ENDDO ENDDO @@ -456,7 +457,7 @@ SUBROUTINE MDL2AGL !--- Min Updraft Helicity 1-6 km IF((IGET(787)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=UP_HELI_MIN16(I,J) ENDDO ENDDO @@ -477,7 +478,7 @@ SUBROUTINE MDL2AGL !--- Max Updraft Helicity 0-2 km IF((IGET(788)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=UP_HELI_MAX02(I,J) ENDDO ENDDO @@ -497,7 +498,7 @@ SUBROUTINE MDL2AGL !--- Min Updraft Helicity 0-2 km IF((IGET(789)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=UP_HELI_MIN02(I,J) ENDDO ENDDO @@ -518,7 +519,7 @@ SUBROUTINE MDL2AGL !--- Max Updraft Helicity 0-3 km IF((IGET(790)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=UP_HELI_MAX03(I,J) ENDDO ENDDO @@ -539,7 +540,7 @@ SUBROUTINE MDL2AGL !--- Min Updraft Helicity 0-3 km IF((IGET(791)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=UP_HELI_MIN03(I,J) ENDDO ENDDO @@ -560,7 +561,7 @@ SUBROUTINE MDL2AGL !--- Max Relative Vertical Vorticity 0-2 km IF((IGET(792)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=REL_VORT_MAX(I,J) ENDDO ENDDO @@ -581,7 +582,7 @@ SUBROUTINE MDL2AGL !--- Max Relative Vertical Vorticity 0-1 km IF((IGET(793)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=REL_VORT_MAX01(I,J) ENDDO ENDDO @@ -601,7 +602,7 @@ SUBROUTINE MDL2AGL !--- Max Relative Vertical Vorticity @ hybrid level 1 IF((IGET(890)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=REL_VORT_MAXHY1(I,J) ENDDO ENDDO @@ -622,7 +623,7 @@ SUBROUTINE MDL2AGL !--- Max Hail Diameter in Column IF((IGET(794)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=HAIL_MAX2D(I,J) ENDDO ENDDO @@ -643,7 +644,7 @@ SUBROUTINE MDL2AGL !--- Max Hail Diameter at k=1 IF((IGET(795)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=HAIL_MAXK1(I,J) ENDDO ENDDO @@ -666,7 +667,7 @@ SUBROUTINE MDL2AGL ! (J. Kenyon/GSD, added 1 May 2019) IF((IGET(728)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=HAIL_MAXHAILCAST(I,J)/1000.0 ! convert mm to m ENDDO ENDDO @@ -687,7 +688,7 @@ SUBROUTINE MDL2AGL !--- Max Column Integrated Graupel IF((IGET(429)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=GRPL_MAX(I,J) ENDDO ENDDO @@ -708,7 +709,7 @@ SUBROUTINE MDL2AGL !--- Max Lightning Threat 1 IF((IGET(702)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=LTG1_MAX(I,J) ENDDO ENDDO @@ -729,7 +730,7 @@ SUBROUTINE MDL2AGL !--- Max Lightning Threat 2 IF((IGET(703)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=LTG2_MAX(I,J) ENDDO ENDDO @@ -750,7 +751,7 @@ SUBROUTINE MDL2AGL !--- Max Lightning Threat 3 IF((IGET(704)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=LTG3_MAX(I,J) ENDDO ENDDO @@ -771,7 +772,7 @@ SUBROUTINE MDL2AGL !--- GSD Updraft Helicity IF((IGET(727)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=UP_HELI(I,J) ENDDO ENDDO @@ -786,7 +787,7 @@ SUBROUTINE MDL2AGL !--- Updraft Helicity 1-6 km layer IF((IGET(701)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=UP_HELI16(I,J) ENDDO ENDDO @@ -801,7 +802,7 @@ SUBROUTINE MDL2AGL !--- Convective Initiation Lightning IF((IGET(705)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=NCI_LTG(I,J)/60.0 ENDDO ENDDO @@ -822,7 +823,7 @@ SUBROUTINE MDL2AGL !--- Convective Activity Lightning IF((IGET(706)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=NCA_LTG(I,J)/60.0 ENDDO ENDDO @@ -843,7 +844,7 @@ SUBROUTINE MDL2AGL !--- Convective Initiation Vertical Hydrometeor Flux IF((IGET(707)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=NCI_WQ(I,J)/60.0 ENDDO ENDDO @@ -864,7 +865,7 @@ SUBROUTINE MDL2AGL !--- Convective Activity Vertical Hydrometeor Flux IF((IGET(708)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=NCA_WQ(I,J)/60.0 ENDDO ENDDO @@ -885,7 +886,7 @@ SUBROUTINE MDL2AGL !--- Convective Initiation Reflectivity IF((IGET(709)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=NCI_REFD(I,J)/60.0 ENDDO ENDDO @@ -906,7 +907,7 @@ SUBROUTINE MDL2AGL !--- Convective Activity Reflectivity IF((IGET(710)>0) )THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=NCA_REFD(I,J)/60.0 ENDDO ENDDO @@ -946,7 +947,7 @@ SUBROUTINE MDL2AGL jj=(jsta+jend)/2 ii=(im)/2 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM UAGL(I,J) = SPVAL VAGL(I,J) = SPVAL ! @@ -1123,7 +1124,7 @@ SUBROUTINE MDL2AGL !--- Wind Shear (wind speed difference in knots between sfc and 2000 ft) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(ABS(UAGL(I,J)-SPVAL)>SMALL .AND. & ABS(VAGL(I,J)-SPVAL)>SMALL)THEN IF(GRIDTYPE=='B' .OR. GRIDTYPE=='E')THEN @@ -1175,7 +1176,7 @@ SUBROUTINE MDL2AGL jj = float(jsta+jend)/2.0 ii = float(im)/3.0 DO J=JSTA_2L,JEND_2U - DO I=ista,iend + DO I=1,IM ! PAGL(I,J) = SPVAL TAGL(I,J) = SPVAL @@ -1219,7 +1220,7 @@ SUBROUTINE MDL2AGL !chc J=JHOLD(NN) ! DO 220 J=JSTA,JEND DO 240 J=JSTA_2L,JEND_2U - DO 240 I=ista,iend + DO 240 I=1,IM LL = NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -1290,11 +1291,16 @@ SUBROUTINE MDL2AGL !--- Wind Energy Potential -- 0.5 * moist air density * wind speed^3 IF((IGET(411)>0) ) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(QAGL(I,J)0) ) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=UAGL(I,J) ENDDO ENDDO @@ -1321,7 +1327,7 @@ SUBROUTINE MDL2AGL !--- V Component of wind IF((IGET(413)>0) ) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=VAGL(I,J) ENDDO ENDDO diff --git a/sorc/ncep_post.fd/MDL2P.f b/sorc/ncep_post.fd/MDL2P.f index 03f67acbd..8f1d27d79 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -28,6 +28,8 @@ !! 20-03-25 J MENG - remove grib1 !! 20-05-20 J MENG - CALRH unification with NAM scheme !! 20-11-10 J MENG - USE UPP_PHYSICS MODULE +!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) +!! 21-04-01 J MENG - COMPUTATION ON DEFINED POINTS ONLY !! !! USAGE: CALL MDL2P !! INPUT ARGUMENT LIST: @@ -71,7 +73,8 @@ SUBROUTINE MDL2P(iostatusD3D) CNVCTUMMIXING, NCNVCTCFRAC, CNVCTUMFLX, CNVCTDETMFLX, & CNVCTZGDRAG, CNVCTMGDRAG, ZMID, ZINT, PMIDV, & CNVCTDMFLX - use vrbls2d, only: T500, W_UP_MAX, W_DN_MAX, W_MEAN, PSLP, FIS, Z1000 + use vrbls2d, only: T500,T700,W_UP_MAX,W_DN_MAX,W_MEAN,PSLP,FIS,Z1000,Z700,& + Z500 use masks, only: LMH, SM use physcons_post,only: CON_FVIRT, CON_ROG, CON_EPS, CON_EPSM1 use params_mod, only: H1M12, DBZMIN, H1, PQ0, A2, A3, A4, RHMIN, G, & @@ -81,7 +84,7 @@ 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,ista,iend + imp_physics use rqstfld_mod, only: IGET, LVLS, ID, IAVBLFLD, LVLSXML use gridspec_mod, only: GRIDTYPE, MAPTYPE, DXVAL use upp_physics, only: FPVSNEW, CALRH @@ -101,7 +104,7 @@ SUBROUTINE MDL2P(iostatusD3D) real,PARAMETER :: CAPA=0.28589641,P1000=1000.E2 LOGICAL IOOMG,IOALL real, dimension(im,jm) :: GRID1, GRID2 - real, dimension(ista:iend,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL & + real, dimension(im,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL & &, Q2SL, WSL, CFRSL, O3SL, TDSL & &, EGRID1, EGRID2 & &, FSL_OLD, USL_OLD, VSL_OLD & @@ -110,11 +113,10 @@ SUBROUTINE MDL2P(iostatusD3D) REAL, allocatable :: D3DSL(:,:,:), DUSTSL(:,:,:), SMOKESL(:,:,:) ! integer,intent(in) :: iostatusD3D - INTEGER, dimension(ista:iend,jsta_2l:jend_2u) :: NL1X, NL1XF - real, dimension(ista:iend,JSTA_2L:JEND_2U,LSM) :: TPRS, QPRS, FPRS + INTEGER, dimension(im,jsta_2l:jend_2u) :: NL1X, NL1XF + real, dimension(IM,JSTA_2L:JEND_2U,LSM) :: TPRS, QPRS, FPRS ! INTEGER K, NSMOOTH -! integer ista,iend ! !--- Definition of the following 2D (horizontal) dummy variables ! @@ -132,9 +134,9 @@ SUBROUTINE MDL2P(iostatusD3D) REAL SDUMMY(IM,2) ! SAVE RH, U,V, for Icing, CAT, LLWS computation - REAL SAVRH(ista:iend,jsta:jend) + REAL SAVRH(IM,jsta:jend) !jw - integer I,J,L,LP,LL,LLMH,JJB,JJE,II,JJ,LI,IFINCR,ITD3D,istaa,imois,luhi,la + integer I,J,L,LP,LL,LLMH,JJB,JJE,II,JJ,LI,IFINCR,ITD3D,ista,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 @@ -143,8 +145,6 @@ SUBROUTINE MDL2P(iostatusD3D) !****************************************************************************** ! ! START MDL2P. - ista=ista - iend=iend ! if (modelname == 'GFS') then zero = 0.0 @@ -156,7 +156,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,l) do l=1,27 do j=1,jm - do i=ista,iend + do i=1,im D3DSL(i,j,l) = SPVAL enddo enddo @@ -167,7 +167,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,l) do l=1,nbin_du do j=1,jm - do i=ista,iend + do i=1,im DUSTSL(i,j,l) = SPVAL enddo enddo @@ -177,7 +177,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,l) do l=1,nbin_sm do j=1,jm - do i=ista,iend + do i=1,im SMOKESL(i,j,l) = SPVAL enddo enddo @@ -251,7 +251,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! !$omp parallel do private(i,j,l) DO J=JSTA_2L,JEND_2U - DO I=ista,iend + DO I=1,IM TSL(I,J) = SPVAL QSL(I,J) = SPVAL FSL(I,J) = SPVAL @@ -317,7 +317,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$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=ista,iend + DO I=1,IM !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC !*** HUMIDITY, CLOUD WATER/ICE, OMEGA, WINDS, AND TKE. @@ -333,8 +333,8 @@ SUBROUTINE MDL2P(iostatusD3D) IF(Q(I,J,1) < SPVAL) QSL(I,J) = Q(I,J,1) IF(gridtype == 'A')THEN - USL(I,J) = UH(I,J,1) - VSL(I,J) = VH(I,J,1) + IF(UH(I,J,1) < SPVAL) USL(I,J) = UH(I,J,1) + IF(VH(I,J,1) < SPVAL) VSL(I,J) = VH(I,J,1) END IF ! if ( J == JSTA.and. I == 1.and.me == 0) & @@ -785,7 +785,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM TPRS(I,J,LP) = TSL(I,J) QPRS(I,J,LP) = QSL(I,J) FPRS(I,J,LP) = FSL(I,J) @@ -870,7 +870,7 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO ! DO J=JSTA,JEND - DO I=ista,iend-MOD(j,2) + DO I=1,IM-MOD(j,2) LL = NL1X(I,J) !--------------------------------------------------------------------- @@ -925,7 +925,7 @@ SUBROUTINE MDL2P(iostatusD3D) END DO ELSE IF(gridtype=='B')THEN ! B grid wind interpolation DO J=JSTA,JEND_m - DO I=ista,iend-1 + DO I=1,IM-1 !*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. ! @@ -955,7 +955,7 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO ! DO J=JSTA,JEND_m - DO I=ista,iend-1 + DO I=1,IM-1 LL = NL1X(I,J) !--------------------------------------------------------------------- @@ -1013,11 +1013,26 @@ SUBROUTINE MDL2P(iostatusD3D) IF(NINT(SPL(LP)) == 50000)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM T500(I,J) = TSL(I,J) + Z500(I,J) = FSL(I,J)*GI ENDDO ENDDO ENDIF + +! +!*** SAVE 700MB TEMPERATURE FOR LIFTED INDEX. +! + IF(NINT(SPL(LP)) == 70000)THEN +!$omp parallel do private(i,j) + DO J=JSTA,JEND + DO I=1,IM + T700(I,J) = TSL(I,J) + Z700(I,J) = FSL(I,J)*GI + ENDDO + ENDDO + ENDIF + ! !--------------------------------------------------------------------- !*** CALCULATE 1000MB GEOPOTENTIALS CONSISTENT WITH SLP OBTAINED @@ -1031,7 +1046,7 @@ SUBROUTINE MDL2P(iostatusD3D) !HC ALPTH=LOG(1.E5) !HC!$omp parallel do private(i,j) !HC DO J=JSTA,JEND -!HC DO I=ista,iend +!HC DO I=1,IM !HC IF(FSL(I,J) < SPVAL) THEN !HC PSLPIJ=PSLP(I,J) !HC ALPSL=LOG(PSLPIJ) @@ -1055,7 +1070,7 @@ SUBROUTINE MDL2P(iostatusD3D) !HC IF(IGET(023)<=0.AND.LP == LSM)THEN !!$omp parallel do private(i,j) !HC DO J=JSTA,JEND -!HC DO I=ista,iend +!HC DO I=1,IM !HC IF(Z1000(I,J) < SPVAL) THEN !HC FSL(I,J)=Z1000(I,J)*G !HC ELSE @@ -1083,7 +1098,7 @@ SUBROUTINE MDL2P(iostatusD3D) ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(FSL(I,J) < SPVAL) THEN GRID1(I,J) = FSL(I,J)*GI ELSE @@ -1104,7 +1119,7 @@ SUBROUTINE MDL2P(iostatusD3D) if(grib == 'grib2')then dxm=dxm/1000.0 endif - print *,'dxm=',dxm +! print *,'dxm=',dxm NSMOOTH = nint(5.*(13500./dxm)) call AllGETHERV(GRID1) do k=1,NSMOOTH @@ -1118,7 +1133,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1134,7 +1149,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(013)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = TSL(I,J) ENDDO ENDDO @@ -1154,7 +1169,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1168,8 +1183,12 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(910))>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(TSL(I,J) < SPVAL .AND. QSL(I,J) < SPVAL) THEN GRID1(I,J) = TSL(I,J)*(1.+0.608*QSL(I,J)) + ELSE + GRID1(I,J) = SPVAL + ENDIF ENDDO ENDDO @@ -1188,7 +1207,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1205,7 +1224,7 @@ SUBROUTINE MDL2P(iostatusD3D) tem = (P1000/spl(lp)) ** capa !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(TSL(I,J) < SPVAL) THEN grid1(I,J) = TSL(I,J) * tem ELSE @@ -1215,7 +1234,7 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO !!$omp parallel do private(i,j) ! DO J=JSTA,JEND -! DO I=ista,iend +! DO I=1,IM ! EGRID2(I,J) = SPL(LP) ! ENDDO ! ENDDO @@ -1223,7 +1242,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! CALL CALPOT(EGRID2,TSL,EGRID1) !!$omp parallel do private(i,j) ! DO J=JSTA,JEND -! DO I=ista,iend +! DO I=1,IM ! GRID1(I,J) = EGRID1(I,J) ! ENDDO ! ENDDO @@ -1235,7 +1254,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1259,7 +1278,7 @@ SUBROUTINE MDL2P(iostatusD3D) if ( log1 ) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EGRID2(I,J) = SPL(LP) ENDDO ENDDO @@ -1268,7 +1287,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(EGRID1(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J)*100. ELSE @@ -1291,7 +1310,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1299,7 +1318,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM SAVRH(I,J) = GRID1(I,J) ENDDO ENDDO @@ -1313,7 +1332,8 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(331)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + GRID1(I,J) = SPVAL CFRSL(I,J) = MIN(MAX(0.0,CFRSL(I,J)),1.0) IF(abs(CFRSL(I,J)-SPVAL) > SMALL) & GRID1(I,J) = CFRSL(I,J)*H100 @@ -1326,7 +1346,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1340,7 +1360,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(015)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EGRID2(I,J) = SPL(LP) ENDDO ENDDO @@ -1348,7 +1368,7 @@ SUBROUTINE MDL2P(iostatusD3D) CALL CALDWP(EGRID2(1,jsta),QSL(1,jsta),EGRID1(1,jsta),TSL(1,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(TSL(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J) ELSE @@ -1363,7 +1383,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1377,7 +1397,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(016)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = QSL(I,J) ENDDO ENDDO @@ -1389,7 +1409,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1403,7 +1423,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(020)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = OSL(I,J) ENDDO ENDDO @@ -1432,7 +1452,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1446,7 +1466,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(284)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = WSL(I,J) ENDDO ENDDO @@ -1457,7 +1477,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1473,7 +1493,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! if(me == 0) print *,'after calmcvgme=',me,'USL=',USL(1:10,JSTA) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1489,7 +1509,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1511,7 +1531,7 @@ SUBROUTINE MDL2P(iostatusD3D) if ( log1 ) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = USL(I,J) GRID2(I,J) = VSL(I,J) ENDDO @@ -1537,7 +1557,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1548,7 +1568,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1564,7 +1584,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! print *,'me=',me,'EGRID1=',EGRID1(1:10,JSTA) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1593,7 +1613,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1606,14 +1626,16 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(086)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(FSL(I,J) 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = Q2SL(I,J) ENDDO ENDDO @@ -1653,7 +1675,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1669,15 +1691,19 @@ 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=ista,iend + DO I=1,IM + IF(QW1(I,J) < SPVAL .AND. QI1(I,J) < SPVAL) THEN GRID1(I,J) = QW1(I,J) + QI1(I,J) QI1(I,J) = spval + ELSE + GRID1(I,J) = SPVAL + ENDIF ENDDO ENDDO ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = QW1(I,J) ENDDO ENDDO @@ -1689,7 +1715,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1703,7 +1729,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(166)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = QI1(I,J) ENDDO ENDDO @@ -1714,7 +1740,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1727,7 +1753,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(183)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = QR1(I,J) ENDDO ENDDO @@ -1738,7 +1764,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1751,7 +1777,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(184)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = QS1(I,J) ENDDO ENDDO @@ -1762,7 +1788,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1775,7 +1801,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(416)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = QG1(I,J) ENDDO ENDDO @@ -1786,7 +1812,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1800,7 +1826,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(198)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = C1D(I,J) ENDDO ENDDO @@ -1811,7 +1837,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1824,7 +1850,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(263)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = FRIME(I,J) ENDDO ENDDO @@ -1835,7 +1861,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1848,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=ista,iend + DO I=1,IM GRID1(I,J) = RAD(I,J) ENDDO ENDDO @@ -1859,7 +1885,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1872,7 +1898,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(251)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = DBZ1(I,J) ENDDO ENDDO @@ -1883,7 +1909,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1898,7 +1924,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1909,7 +1935,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1925,8 +1951,12 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(258)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(FSL(I,J) 3. .OR. GRID1(I,J) < 0.) ! + print*,'bad CAT',i,j,GRID1(I,J) @@ -1948,7 +1978,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1960,10 +1990,14 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=ista,iend + DO I=1,IM 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=ista,iend + DO I=1,IM GRID1(I,J) = O3SL(I,J) ENDDO ENDDO @@ -1985,7 +2019,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1998,8 +2032,12 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(738)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(SMOKESL(I,J,1) 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = DUSTSL(I,J,1) ENDDO ENDDO @@ -2033,7 +2071,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2045,7 +2083,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(439)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = DUSTSL(I,J,2) ENDDO ENDDO @@ -2056,7 +2094,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2068,7 +2106,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(440)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = DUSTSL(I,J,3) ENDDO ENDDO @@ -2079,7 +2117,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2091,7 +2129,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(441)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = DUSTSL(I,J,4) ENDDO ENDDO @@ -2102,7 +2140,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2114,7 +2152,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(442)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = DUSTSL(I,J,5) ENDDO ENDDO @@ -2125,7 +2163,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2141,7 +2179,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(355)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,1) ENDDO ENDDO @@ -2176,7 +2214,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2188,7 +2226,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(354)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,2) ENDDO ENDDO @@ -2223,7 +2261,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2235,7 +2273,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(356)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,3) ENDDO ENDDO @@ -2270,7 +2308,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2282,7 +2320,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(357)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,4) ENDDO ENDDO @@ -2317,7 +2355,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2329,7 +2367,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(358)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,5) ENDDO ENDDO @@ -2364,7 +2402,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2376,7 +2414,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(359)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,6) ENDDO ENDDO @@ -2411,7 +2449,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2423,7 +2461,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(360)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,7) ENDDO ENDDO @@ -2458,7 +2496,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2470,7 +2508,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(361)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,8) ENDDO ENDDO @@ -2505,7 +2543,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2517,7 +2555,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(362)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,9) ENDDO ENDDO @@ -2552,7 +2590,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2564,7 +2602,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(363)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,10) ENDDO ENDDO @@ -2600,7 +2638,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2612,7 +2650,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(364)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,11) ENDDO ENDDO @@ -2648,7 +2686,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2660,7 +2698,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(365)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,12) ENDDO ENDDO @@ -2696,7 +2734,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2708,7 +2746,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(366)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,13) ENDDO ENDDO @@ -2744,7 +2782,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2756,7 +2794,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(367)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,14) ENDDO ENDDO @@ -2792,7 +2830,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2804,7 +2842,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(368)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,15) ENDDO ENDDO @@ -2840,7 +2878,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2852,7 +2890,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(369)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,16) ENDDO ENDDO @@ -2887,7 +2925,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2899,7 +2937,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(370)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,17) ENDDO ENDDO @@ -2935,7 +2973,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2947,7 +2985,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(371)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,18) ENDDO ENDDO @@ -2983,7 +3021,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2995,7 +3033,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(372)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,19) ENDDO ENDDO @@ -3030,7 +3068,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3042,7 +3080,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(373)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,20) ENDDO ENDDO @@ -3078,7 +3116,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3090,7 +3128,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(374)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,21) ENDDO ENDDO @@ -3126,7 +3164,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3138,7 +3176,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(375)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,22) ENDDO ENDDO @@ -3173,7 +3211,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3185,7 +3223,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(379)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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) & @@ -3226,7 +3264,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3238,7 +3276,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(391)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,23) ENDDO ENDDO @@ -3274,7 +3312,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3286,7 +3324,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(392)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,24) ENDDO ENDDO @@ -3322,7 +3360,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3334,7 +3372,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(393)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,25) ENDDO ENDDO @@ -3370,7 +3408,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3382,7 +3420,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(394)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,26) ENDDO ENDDO @@ -3418,7 +3456,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3430,7 +3468,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(395)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = D3DSL(i,j,27) ENDDO ENDDO @@ -3466,7 +3504,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3485,7 +3523,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! print*,'computing dew point for Haine Index at ',SPL(LP) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM HAINES(i,j) = SPVAL EGRID2(I,J) = SPL(LP) ENDDO @@ -3494,15 +3532,15 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j,dum1,ista,imois) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(SM(I,J) < 1.0 .AND. ZINT(I,J,LM+1) < FSL(I,J)*GI) THEN DUM1 = TSL(I,J)-TPRS(I,J,LUHI) IF(DUM1 <= 17.)THEN - ISTAA = 1 + ISTA = 1 ELSE IF(DUM1 > 17. .AND. DUM1 <= 21.) THEN - ISTAA = 2 + ISTA = 2 ELSE - ISTAA = 3 + ISTA = 3 END IF DUM1 = TSL(I,J)-TDSL(I,J) IF(DUM1 <= 14.) THEN @@ -3512,7 +3550,11 @@ SUBROUTINE MDL2P(iostatusD3D) ELSE IMOIS = 3 END IF - HAINES(I,J) = ISTAA + IMOIS + IF(TSL(I,J) 5. .AND. DUM1 <= 10.) THEN - ISTAA = 2 + ISTA = 2 ELSE - ISTAA = 3 + ISTA = 3 END IF DUM1 = TSL(I,J)-TDSL(I,J) IF(DUM1 <= 5.) THEN @@ -3554,7 +3596,11 @@ SUBROUTINE MDL2P(iostatusD3D) END IF ! 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) - HAINES(I,J) = ISTAA + IMOIS + IF(TSL(I,J) 3. .AND. DUM1 <=7. ) THEN - ISTAA = 2 + ISTA = 2 ELSE - ISTAA = 3 + ISTA = 3 END IF DUM1 = TSL(I,J)-TDSL(I,J) IF(DUM1 <=5. ) THEN @@ -3593,8 +3639,12 @@ SUBROUTINE MDL2P(iostatusD3D) IMOIS = 3 END IF ! if(i==570 .and. j==574)print*,'low haines index:',i,j,luhi,tsl(i,j) & -! ,tprs(i,j,luhi),tdsl(i,j),istaa,imois,spl(luhi),spl(lp),haines(i,j) - HAINES(I,J) = ISTAA + IMOIS +! ,tprs(i,j,luhi),tdsl(i,j),ista,imois,spl(luhi),spl(lp),haines(i,j) + IF(TSL(I,J)0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(FSL1(I,J)0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=AKH(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(243)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif if(me==0)print*,'output Heat Diffusivity' @@ -351,7 +353,7 @@ SUBROUTINE MDL2SIGMA NHOLD=0 ! DO J=JSTA_2L,JEND_2U - DO I=ista,iend + DO I=1,IM ! TSL(I,J)=SPVAL @@ -405,7 +407,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=ista,iend + DO 220 I=1,IM LL=NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -553,7 +555,7 @@ SUBROUTINE MDL2SIGMA ! ! OBTAIN GEOPOTENTIAL AND KH ON INTERFACES DO J=JSTA_2L,JEND_2U - DO I=ista,iend + DO I=1,IM FSL(I,J)=SPVAL AKH(I,J)=SPVAL NL1XF(I,J)=LP1 @@ -569,7 +571,7 @@ SUBROUTINE MDL2SIGMA ! ! DO J=JSTA_2L,JEND_2U DO J=JSTA,JEND ! Moorthi on 26 Nov 2014 - DO I=ista,iend + DO I=1,IM DONEFSL1=.FALSE. TSLDONE=.FALSE. LLMH = NINT(LMH(I,J)) @@ -719,10 +721,10 @@ SUBROUTINE MDL2SIGMA ! VERTICAL INTERPOLATION FOR WIND FOR E and B GRIDS ! if(gridtype=='B' .or. gridtype=='E') & - call exch(PINT(ista:iend,JSTA_2L:JEND_2U,LP1)) + call exch(PINT(1:IM,JSTA_2L:JEND_2U,LP1)) IF(gridtype=='E')THEN DO J=JSTA,JEND - DO I=ista,iend-MOD(J,2) + DO I=1,IM-MOD(J,2) ! !*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. @@ -764,7 +766,7 @@ SUBROUTINE MDL2SIGMA ENDDO ! DO 230 J=JSTA,JEND - DO 230 I=ista,iend-MOD(j,2) + DO 230 I=1,IM-MOD(j,2) LLMH = NINT(LMH(I,J)) IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC PDV=0.5*(PINT(I,J,LLMH+1)+PINT(I+1,J,LLMH+1)) @@ -827,7 +829,7 @@ SUBROUTINE MDL2SIGMA ELSE IF (gridtype=='B')THEN DO J=JSTA,JEND_M - DO I=ista,iend-1 + DO I=1,IM-1 ! !*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. @@ -856,7 +858,7 @@ SUBROUTINE MDL2SIGMA ENDDO ! DO 231 J=JSTA,JEND_M - DO 231 I=ista,iend-1 + DO 231 I=1,IM-1 PDV=0.25*(PINT(I,J,LP1)+PINT(I+1,J,LP1) & +PINT(I,J+1,LP1)+PINT(I+1,J+1,LP1)) PSIGO=PTSIGO+ASIGO(LP)*(PDV-PTSIGO) @@ -927,7 +929,7 @@ SUBROUTINE MDL2SIGMA IF(LVLS(LP+1,IGET(205))>0)THEN !$omp parallel do DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(FSL(I,J)0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=AKH(I,J) IF(LP==(LSIG+1))GRID1(I,J)=0.0 !! NO SLIP ASSUMTION FOR CMAQ ENDDO @@ -960,7 +962,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(243)) fld_info(cfld)%lvl=LVLSXML(LP+1,IGET(243)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif if(me==0)print*,'output Heat Diffusivity' ENDIF @@ -971,7 +973,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(206)>0) THEN IF(LVLS(LP,IGET(206))>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=TSL(I,J) ENDDO ENDDO @@ -979,7 +981,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(206)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(206)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF ENDIF @@ -990,7 +992,7 @@ SUBROUTINE MDL2SIGMA IF(LVLS(LP,IGET(216))>0)THEN !$omp parallel do DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM LLMH = NINT(LMH(I,J)) GRID1(I,J)=PTSIGO+ASIGO(LP)*(PINT(I,J,LLMH+1)-PTSIGO) ENDDO @@ -999,7 +1001,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(216)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(216)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF ENDIF @@ -1009,7 +1011,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(207)>0)THEN IF(LVLS(LP,IGET(207))>0)THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=QSL(I,J) ENDDO ENDDO @@ -1018,7 +1020,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(207)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(207)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF ENDIF @@ -1028,7 +1030,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(210)>0)THEN IF(LVLS(LP,IGET(210))>0)THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=OSL(I,J) ENDDO ENDDO @@ -1036,7 +1038,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(210)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(210)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF ENDIF @@ -1046,7 +1048,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=ista,iend + DO I=1,IM GRID1(I,J)=USL(I,J) GRID2(I,J)=VSL(I,J) ENDDO @@ -1055,11 +1057,11 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(208)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(208)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(209)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(209)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF ENDIF @@ -1069,7 +1071,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(217)>0) THEN IF (LVLS(LP,IGET(217))>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=Q2SL(I,J) ENDDO ENDDO @@ -1077,7 +1079,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(217)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(217)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF ENDIF @@ -1087,7 +1089,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(211)>0) THEN IF (LVLS(LP,IGET(211))>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=QW1(I,J) ENDDO ENDDO @@ -1095,7 +1097,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(211)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(211)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF ENDIF @@ -1105,7 +1107,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(212)>0) THEN IF (LVLS(LP,IGET(212))>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=QI1(I,J) ENDDO ENDDO @@ -1113,7 +1115,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(212)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(212)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF ENDIF @@ -1122,7 +1124,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(213)>0) THEN IF (LVLS(LP,IGET(213))>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=QR1(I,J) ENDDO ENDDO @@ -1130,7 +1132,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(213)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(213)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF ENDIF @@ -1139,7 +1141,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(214)>0) THEN IF (LVLS(LP,IGET(214))>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=QS1(I,J) ENDDO ENDDO @@ -1147,7 +1149,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(214)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(214)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF ENDIF @@ -1156,7 +1158,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(255)>0) THEN IF (LVLS(LP,IGET(255))>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=QG1(I,J) ENDDO ENDDO @@ -1164,7 +1166,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(255)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(255)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF ENDIF @@ -1173,7 +1175,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(215)>0) THEN IF (LVLS(LP,IGET(215))>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=C1D(I,J) ENDDO ENDDO @@ -1181,7 +1183,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(215)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(215)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF ENDIF @@ -1190,7 +1192,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(222)>0) THEN IF (LVLS(LP,IGET(222))>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=CFRSIG(I,J) ENDDO ENDDO @@ -1198,7 +1200,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(222)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(222)) - datapd(ista:iend,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF ENDIF diff --git a/sorc/ncep_post.fd/MDL2SIGMA2.f b/sorc/ncep_post.fd/MDL2SIGMA2.f index 2529e9712..aea8c2e4b 100644 --- a/sorc/ncep_post.fd/MDL2SIGMA2.f +++ b/sorc/ncep_post.fd/MDL2SIGMA2.f @@ -18,6 +18,7 @@ !! 02-07-29 H CHUANG - ADD UNDERGROUND FIELDS AND MEMBRANE SLP FOR WRF !! 04-11-24 H CHUANG - ADD FERRIER'S HYDROMETEOR FIELD !! 20-03-25 J MENG - remove grib1 +!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) !! !! USAGE: CALL MDL2P !! INPUT ARGUMENT LIST: @@ -48,7 +49,7 @@ 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,ista,iend + grib, cfld, datapd, fld_info, im, jm, im_jm use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml ! implicit none @@ -59,12 +60,12 @@ SUBROUTINE MDL2SIGMA2 ! LOGICAL READTHK ! REAL,dimension(im,jm) :: FSL, TSL, QSL, osl, usl, vsl, q2sl, fsl1, & - REAL,dimension(ista:iend,jsta_2l:jend_2u) :: TSL - REAL,dimension(im,jm) :: grid1 + REAL,dimension(im,jsta_2l:jend_2u) :: TSL + REAL,dimension(im,jsta_2l:jend_2u) :: grid1 REAL SIGO(LSIG+1),DSIGO(LSIG),ASIGO(LSIG) ! ! INTEGER,dimension(im,jm) :: IHOLD,JHOLD,NL1X,NL1XF - INTEGER,dimension(ista:iend,jsta_2l:jend_2u) :: NL1X + INTEGER,dimension(im,jsta_2l:jend_2u) :: NL1X ! ! !--- Definition of the following 2D (horizontal) dummy variables @@ -132,7 +133,7 @@ SUBROUTINE MDL2SIGMA2 NHOLD=0 ! DO J=JSTA_2L,JEND_2U - DO I=ista,iend + DO I=1,IM ! TSL(I,J)=SPVAL @@ -173,7 +174,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=ista,iend + DO 220 I=1,IM LL=NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -261,7 +262,7 @@ SUBROUTINE MDL2SIGMA2 IF(IGET(296)>0) THEN IF(LVLS(LP,IGET(296))>0)THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=TSL(I,J) ENDDO ENDDO diff --git a/sorc/ncep_post.fd/MDLFLD.f b/sorc/ncep_post.fd/MDLFLD.f index 11c6b5e07..37e91ff4d 100644 --- a/sorc/ncep_post.fd/MDLFLD.f +++ b/sorc/ncep_post.fd/MDLFLD.f @@ -42,6 +42,7 @@ !! 20-05-20 J MENG - CALRH unification with NAM scheme !! 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 !! !! USAGE: CALL MDLFLD !! INPUT ARGUMENT LIST: @@ -95,7 +96,7 @@ 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,ista,iend + me, dt, avrain, theat, ifhr, ifmin, avcnvc, lp1, im, jm use rqstfld_mod, only: iget, id, lvls, iavblfld, lvlsxml use gridspec_mod, only: gridtype,maptype,dxval use upp_physics, only: CALRH, CALCAPE @@ -127,7 +128,7 @@ SUBROUTINE MDLFLD LOGICAL NMM_GFSmicro LOGiCAL Model_Radar real, dimension(im,jm) :: GRID1, GRID2 - real, dimension(ista:iend,jsta_2l:jend_2u) :: EGRID1, EGRID2, EGRID3, EGRID4, EGRID5,& + real, dimension(im,jsta_2l:jend_2u) :: EGRID1, EGRID2, EGRID3, EGRID4, EGRID5,& EL0, P1D, T1D, Q1D, C1D, & FI1D, FR1D, FS1D, QW1, QI1, & QR1, QS1, CUREFL_S, & @@ -158,8 +159,8 @@ SUBROUTINE MDLFLD integer ks,nsmooth REAL SDUMMY(IM,2),dxm ! added to calculate cape and cin for icing - real, dimension(ista:iend,jsta:jend) :: dummy, cape, cin - integer idummy(ista:iend,jsta:jend) + real, dimension(im,jsta:jend) :: dummy, cape, cin + integer idummy(IM,jsta:jend) real, PARAMETER :: ZSL=0.0, TAUCR=RD*GI*290.66, CONST=0.005*G/RD, GORD=G/RD logical, parameter :: debugprint = .false. @@ -184,7 +185,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=ista,iend + DO I=1,IM IF(ABS(REF_10CM(I,J,L)-SPVAL)>SMALL) THEN Model_Radar=.True. exit check_ref @@ -194,16 +195,16 @@ 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 (ista:iend,JSTA_2L:JEND_2U,LM)) - ALLOCATE(RICHNO (ista:iend,JSTA_2L:JEND_2U,LM)) - ALLOCATE(PBLRI (ista:iend,JSTA_2L:JEND_2U)) + ALLOCATE(EL (IM,JSTA_2L:JEND_2U,LM)) + ALLOCATE(RICHNO (IM,JSTA_2L:JEND_2U,LM)) + ALLOCATE(PBLRI (IM,JSTA_2L:JEND_2U)) ! ! SECOND, STANDARD NGM SEA LEVEL PRESSURE. IF (IGET(105) > 0) THEN CALL NGMSLP !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SLP(I,J) ENDDO ENDDO @@ -213,7 +214,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -229,7 +230,7 @@ SUBROUTINE MDLFLD ! print*,'DTQ2 in MDLFLD= ',DTQ2 RDTPHS=24.*3.6E6/DTQ2 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF ((HBOT(I,J)-HTOP(I,J)) <= 1.0) THEN ICBOT(I,J)=0 ICTOP(I,J)=0 @@ -257,7 +258,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=ista,iend + ENDDO !--- DO I=1,IM ENDDO !--- DO J=JSTA,JEND ENDIF !-- IF (MODELNAME=='NMM' .OR. imp_physics==5) THEN ! @@ -275,7 +276,7 @@ SUBROUTINE MDLFLD .or. NMM_GFSmicro)THEN RDTPHS=3.6E6/DTQ2 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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 @@ -311,7 +312,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=ista,iend + DO I=1,IM P1D(I,J)=PMID(I,J,L) T1D(I,J)=T(I,J,L) Q1D(I,J)=Q(I,J,L) @@ -364,7 +365,8 @@ SUBROUTINE MDLFLD refl_miss: IF (Model_Radar) THEN ! - Model output DBZ is present - proceed with calc DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(P1D(I,J) LLMH) THEN QQW(I,J,L) = D00 @@ -481,7 +492,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=ista,iend + DO I=1,IM LLMH = NINT(LMH(I,J)) IF (L > LLMH) THEN QQW(I,J,L) = D00 @@ -509,7 +520,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=ista,iend + DO I=1,IM LLMH = NINT(LMH(I,J)) IF (L > LLMH) THEN QQW(I,J,L)=D00 @@ -539,7 +550,6 @@ SUBROUTINE MDLFLD DBZ(I,J,L)=MAX(DBZmin, DBZ(I,J,L)) DBZR(I,J,L)=MAX(DBZmin, DBZR(I,J,L)) DBZI(I,J,L)=MAX(DBZmin, DBZI(I,J,L)) - ENDIF !-- End IF (L > LMH(I,J)) ... ENDDO !-- End DO I loop ENDDO @@ -549,7 +559,7 @@ SUBROUTINE MDLFLD .and. imp_physics==8)THEN !NMMB or FV3R +THOMPSON DO L=1,LM DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM DBZ(I,J,L)=REF_10CM(I,J,L) ENDDO ENDDO @@ -557,7 +567,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=ista,iend + DO I=1,IM DBZ(I,J,L)=SPVAL ENDDO ENDDO @@ -575,7 +585,7 @@ SUBROUTINE MDLFLD ! Chuang: add convective contribution for all MP schemes RDTPHS=3.6E6/DTQ2 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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 @@ -607,7 +617,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=ista,iend + DO I=1,IM !--- Estimate radar reflectivity factor from convection at level L ! CUREFL(I,J)=0. @@ -630,6 +640,7 @@ SUBROUTINE MDLFLD DBZC(I,J,L)=CUREFL(I,J) ENDIF !-- End IF (CUREFL_S(I,J) > 0.) + IF(T(I,J,L) 1.0E-3) & & DENS = PMID(I,J,L)/(RD*T(I,J,L)*(Q(I,J,L)*D608+1.0)) ! DENSITY @@ -695,6 +706,12 @@ SUBROUTINE MDLFLD DBZI(I,J,L) = MAX(DBZmin, DBZI(I,J,L)) DBZC(I,J,L) = MAX(DBZmin, DBZC(I,J,L)) END IF + ELSE + DBZ(I,J,L) = DBZmin + DBZR(I,J,L) = DBZmin + DBZI(I,J,L) = DBZmin + DBZC(I,J,L) = DBZmin + ENDIF !(T(I,J,L) 1.0E-3) & RHOD=PMID(I,J,LL)/ & @@ -821,7 +839,11 @@ SUBROUTINE MDLFLD DBZ(i,j,ll) = ze_sum DBZR(i,j,ll) = ze_r*1.E18 DBZI(i,j,ll) = (ze_s+ze_g)*1.E18 - + ELSE + DBZ(i,j,ll) = DBZmin + DBZR(i,j,ll) = DBZmin + DBZI(i,j,ll) = DBZmin + ENDIF !T(I,J,LL)0).OR.(IGET(077)>0).OR. & (IGET(002)>0).OR.(IGET(003)>0).OR. & (IGET(004)>0).OR.(IGET(005)>0).OR. & @@ -895,7 +917,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PMID(I,J,LL) ENDDO ENDDO @@ -906,7 +928,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -922,7 +944,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = QQW(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -934,7 +956,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -949,7 +971,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j,jj) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = QQI(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -961,7 +983,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -976,7 +998,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = QQR(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -988,7 +1010,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1003,7 +1025,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = QQS(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -1015,7 +1037,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1030,7 +1052,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(QQG(I,J,LL) < 1.e-12) QQG(I,J,LL) = 0. !tgs GRID1(I,J) = QQG(I,J,LL) ENDDO @@ -1042,7 +1064,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1057,7 +1079,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(QQNW(I,J,LL) < 1.e-8) QQNW(I,J,LL) = 0. !tgs GRID1(I,J) = QQNW(I,J,LL) ENDDO @@ -1069,7 +1091,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1084,7 +1106,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(QQNI(I,J,LL) < 1.e-8) QQNI(I,J,LL) = 0. !tgs GRID1(I,J) = QQNI(I,J,LL) ENDDO @@ -1096,7 +1118,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1111,7 +1133,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(QQNR(I,J,LL) < 1.e-8) QQNR(I,J,LL) = 0. !tgs GRID1(I,J) = QQNR(I,J,LL) ENDDO @@ -1123,7 +1145,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1136,7 +1158,7 @@ SUBROUTINE MDLFLD IF (LVLS(L,IGET(766)) > 0)THEN LL=LM-L+1 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(QQNWFA(I,J,LL)<1.e-8)QQNWFA(I,J,LL)=0. !tgs GRID1(I,J)=QQNWFA(I,J,LL) ENDDO @@ -1156,7 +1178,7 @@ SUBROUTINE MDLFLD IF (LVLS(L,IGET(767)) > 0)THEN LL=LM-L+1 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if(QQNIFA(I,J,LL)<1.e-8)QQNIFA(I,J,LL)=0. !tgs GRID1(I,J)=QQNIFA(I,J,LL) ENDDO @@ -1177,7 +1199,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(abs(CFR(I,J,LL)-SPVAL) > SMALL) & & GRID1(I,J) = CFR(I,J,LL)*H100 ENDDO @@ -1190,7 +1212,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1205,7 +1227,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(MODELNAME == 'RAPR') THEN GRID1(I,J) = CFR(I,J,LL) ELSE @@ -1220,7 +1242,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1244,14 +1266,14 @@ SUBROUTINE MDLFLD IF(IMP_PHYSICS == 8 .or. IMP_PHYSICS == 28) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = REF_10CM(I,J,LL) ENDDO ENDDO ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = DBZ(I,J,LL) ENDDO ENDDO @@ -1265,7 +1287,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1281,7 +1303,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = CWM(I,J,LL) ENDDO ENDDO @@ -1292,7 +1314,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1307,7 +1329,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = F_rain(I,J,LL) ENDDO ENDDO @@ -1318,7 +1340,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1333,7 +1355,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = F_ice(I,J,LL) ENDDO ENDDO @@ -1344,7 +1366,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1360,7 +1382,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = F_RimeF(I,J,LL) ENDDO ENDDO @@ -1371,7 +1393,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1386,7 +1408,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ZMID(I,J,LL) ENDDO ENDDO @@ -1397,7 +1419,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1412,7 +1434,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = T(I,J,LL) ENDDO ENDDO @@ -1423,7 +1445,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1438,8 +1460,12 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(T(I,J,LL) 0) then @@ -1554,7 +1590,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1569,7 +1605,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM P1D(I,J) = PMID(I,J,LL) T1D(I,J) = T(I,J,LL) Q1D(I,J) = Q(I,J,LL) @@ -1578,8 +1614,12 @@ SUBROUTINE MDLFLD CALL CALDWP(P1D(1,jsta),Q1D(1,jsta),EGRID3(1,jsta),T1D(1,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(P1D(I,J)0 .AND. LLL>0)THEN @@ -1680,7 +1729,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1696,7 +1745,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = UH(I,J,LL) GRID2(I,J) = VH(I,J,LL) ENDDO @@ -1708,7 +1757,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1718,7 +1767,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1732,7 +1781,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = OMGA(I,J,LL) ENDDO ENDDO @@ -1743,7 +1792,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1757,7 +1806,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=WH(I,J,LL) ENDDO ENDDO @@ -1768,7 +1817,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1782,7 +1831,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=ista,iend + DO I=1,IM EGRID1(I,J) = UH(I,J,LL) EGRID2(I,J) = VH(I,J,LL) ENDDO @@ -1790,8 +1839,12 @@ SUBROUTINE MDLFLD CALL CALVOR(EGRID1,EGRID2,EGRID3) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(EGRID3(I,J)0) THEN !HC IF (LVLS(L,IGET(124))>0) THEN !HC DO J=JSTA,JEND -!HC DO I=ista,iend +!HC DO I=1,IM !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,GRIDista,iend,JM) +!HC CALL GRIBIT(IGET(124),L,GRID1,IM,JM) !HC ENDIF !HC ENDIF ! @@ -1886,12 +1939,12 @@ SUBROUTINE MDLFLD ! IF (IGET(125)>0) THEN ! IF (LVLS(L,IGET(125))>0) THEN ! DO J=JSTA,JEND -! DO I=ista,iend +! DO I=1,IM ! GRID1(I,J)=QICE(I,J,L) ! ENDDO ! ENDDO ! ID(1:25) = 0 -! CALL GRIBIT(IGET(125),L,GRIDista,iend,JM) +! CALL GRIBIT(IGET(125),L,GRID1,IM,JM) ! ENDIF ! ENDIF ! @@ -1901,12 +1954,12 @@ SUBROUTINE MDLFLD ! IF (IGET(145)>0) THEN ! IF (LVLS(L,IGET(145))>0) THEN ! DO J=JSTA,JEND -! DO I=ista,iend +! DO I=1,IM ! GRID1(I,J)=CFRC(I,J,L) ! ENDDO ! ENDDO ! ID(1:25) = 0 -! CALL GRIBIT(IGET(145),L,GRIDista,iend,JM) +! CALL GRIBIT(IGET(145),L,GRID1,IM,JM) ! ENDIF ! ENDIF ! @@ -1917,7 +1970,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = TTND(I,J,LL) ENDDO ENDDO @@ -1928,7 +1981,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1943,7 +1996,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RSWTT(I,J,LL) ENDDO ENDDO @@ -1954,7 +2007,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1969,7 +2022,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RLWTT(I,J,LL) ENDDO ENDDO @@ -1980,7 +2033,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2002,8 +2055,12 @@ SUBROUTINE MDLFLD ENDIF !$omp parallel do DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(TRAIN(I,J,LL)ug/m3 + ELSE + GRID1(I,J) = spval + ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2164,7 +2233,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2178,9 +2247,13 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(DUST(I,J,LL,2)ug/m3 + ELSE + GRID1(I,J) = spval + ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2190,7 +2263,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2204,10 +2277,14 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(DUST(I,J,LL,3)ug/m3 - ENDDO + ELSE + GRID1(I,J) = spval + ENDIF + ENDDO ENDDO if(grib=="grib2") then cfld=cfld+1 @@ -2216,7 +2293,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2230,9 +2307,13 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(DUST(I,J,LL,4)ug/m3 + ELSE + GRID1(I,J) = spval + ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2242,7 +2323,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2256,9 +2337,13 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(DUST(I,J,LL,5)ug/m3 + ELSE + GRID1(I,J) = spval + ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2268,7 +2353,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2282,8 +2367,12 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(SALT(I,J,LL,1)ug/m3 + ELSE + GRID1(I,J) = spval + ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2293,7 +2382,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2307,8 +2396,12 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(SALT(I,J,LL,2)ug/m3 + ELSE + GRID1(I,J) = spval + ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2318,7 +2411,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2332,8 +2425,12 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(SALT(I,J,LL,3)ug/m3 + ELSE + GRID1(I,J) = spval + ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2343,7 +2440,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2357,8 +2454,12 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(SALT(I,J,LL,4)ug/m3 + ELSE + GRID1(I,J) = spval + ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2368,7 +2469,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2382,8 +2483,12 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(SALT(I,J,LL,5)ug/m3 + ELSE + GRID1(I,J) = spval + ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2393,7 +2498,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2407,9 +2512,13 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(SUSO(I,J,LL,1)ug/m3 + ELSE + GRID1(I,J) = spval + ENDIF ENDDO ENDDO if(grib=="grib2") then @@ -2419,7 +2528,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2433,9 +2542,13 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(WASO(I,J,LL,1)0) THEN ! RDTPHS=1000./DTQ2 ! DO J=JSTA,JEND -! DO I=ista,iend +! DO I=1,IM ! GRID1(I,J)=CPRATE(I,J)*RDTPHS ! GRID1(I,J)=SPVAL ! ENDDO ! ENDDO ! ID(1:25) = 0 -! CALL GRIBIT(IGET(249),LM,GRIDista,iend,JM) +! CALL GRIBIT(IGET(249),LM,GRID1,IM,JM) ! ENDIF ! ! COMPOSITE RADAR REFLECTIVITY (maximum dBZ in each column) @@ -2659,7 +2784,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=ista,iend + DO I=1,IM GRID1(I,J) = DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J) = MAX( GRID1(I,J), DBZ(I,J,L) ) @@ -2679,7 +2804,7 @@ SUBROUTINE MDLFLD MODELNAME=='NMM' .and. gridtype=='E')THEN !$omp parallel do private(i,j,l) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J) = MAX( GRID1(I,J), REF_10CM(I,J,L) ) @@ -2689,7 +2814,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = REFC_10CM(I,J) ENDDO ENDDO @@ -2698,7 +2823,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = refl(i,j) ENDDO ENDDO @@ -2711,7 +2836,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2723,10 +2848,10 @@ SUBROUTINE MDLFLD ! on emprical conversion factors (0.00344) IF (IGET(581)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=0.0 DO L=1,NINT(LMH(I,J)) - if(zint(i,j,l) < spval) then + if(zint(i,j,l) < spval .and.zint(i,j,l+1)0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J)=MAX( GRID1(I,J), DBZR(I,J,L) ) @@ -2763,7 +2888,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2775,7 +2900,7 @@ SUBROUTINE MDLFLD ! IF (IGET(277)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J)=MAX( GRID1(I,J), DBZI(I,J,L) ) @@ -2788,7 +2913,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2802,7 +2927,7 @@ SUBROUTINE MDLFLD ! IF (IGET(278)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J)=MAX( GRID1(I,J), DBZC(I,J,L) ) @@ -2815,7 +2940,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2828,7 +2953,7 @@ SUBROUTINE MDLFLD IF (IGET(426)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=0.0 DO L=1,NINT(LMH(I,J)) IF (DBZ(I,J,L)>=18.0) THEN @@ -2844,7 +2969,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2863,7 +2988,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=ista,iend + DO I=1,IM GRID1(I,J) = -999. DO L=1,NINT(LMH(I,J)) IF (REF_10CM(I,J,L)>=18.0) THEN @@ -2892,7 +3017,7 @@ SUBROUTINE MDLFLD ENDDO ELSE DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = -999. DO L=1,NINT(LMH(I,J)) IF (DBZ(I,J,L) >= 18.0) THEN @@ -2909,7 +3034,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2920,13 +3045,19 @@ SUBROUTINE MDLFLD ! IF (IGET(769)>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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=ista,iend + DO I=1,IM GRID1(I,J) = 0.0 DO L=1,NINT(LMH(I,J)) IF (REF_10CM(I,J,L) > -10.0 ) THEN @@ -2963,7 +3094,7 @@ SUBROUTINE MDLFLD ENDDO ELSE DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = 0.0 DO L=1,NINT(LMH(I,J)) GRID1(I,J) = GRID1(I,J) + 0.00344 * & @@ -2979,7 +3110,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2996,7 +3127,7 @@ SUBROUTINE MDLFLD !--- Needed values at 1st level above ground (Jin, '01; Ferrier, Feb '02) ! DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM LLMH=NINT(LMH(I,J)) Q1D(I,J)=Q(I,J,LLMH) if(Q1D(I,J)<=0.) Q1D(I,J)=0. !tgs @@ -3075,11 +3206,15 @@ SUBROUTINE MDLFLD ! DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(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) - GRID1(I,J)=VIS(I,J) + IF(Q1D(I,J)0) THEN CALL CALVIS_GSD(CZEN,VIS) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J)=VIS(I,J) + DO I=1,IM + IF(Q1D(I,J)0) THEN Zm10c=spval DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! dong handle missing value if (slp(i,j) < spval) then Zm10c(I,J)=ZMID(I,J,NINT(LMH(I,J))) @@ -3204,7 +3343,7 @@ SUBROUTINE MDLFLD IF(IMP_PHYSICS==8 .or. IMP_PHYSICS==28) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=spval ! dong handle missing value if (slp(i,j) < spval) then @@ -3215,7 +3354,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=spval ! dong handle missing value if (slp(i,j) < spval) then @@ -3248,7 +3387,7 @@ SUBROUTINE MDLFLD IF (IGET(147)>0) THEN ! DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = EL0(I,J) ENDDO ENDDO @@ -3268,7 +3407,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,l) DO L=1,LM DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EL(I,J,L) = D00 ENDDO ENDDO @@ -3279,7 +3418,7 @@ SUBROUTINE MDLFLD ELSE IF(MODELNAME == 'NMM')THEN DO L=1,LM DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EL(I,J,L)=EL_PBL(I,J,L) !NOW EL COMES OUT OF WRF NMM ENDDO ENDDO @@ -3302,7 +3441,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = EL(I,J,LL) ENDDO ENDDO @@ -3313,7 +3452,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3329,7 +3468,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RICHNO(I,J,LL) ENDDO ENDDO @@ -3340,7 +3479,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3373,7 +3512,7 @@ SUBROUTINE MDLFLD IF (IGET(289) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PBLRI(I,J) ! PBLH(I,J) = PBLRI(I,J) ENDDO @@ -3384,7 +3523,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3398,15 +3537,19 @@ SUBROUTINE MDLFLD IF ( (IGET(389) > 0) .OR. (IGET(454) > 0) ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(PBLRI(I,J) 0.)THEN GRID1(I,J) = EGRID1(I,J)/EGRID2(I,J) ELSE @@ -3448,7 +3594,7 @@ SUBROUTINE MDLFLD CALL H2V(EGRID3(1:im,JSTA_2L:JEND_2U),EGRID4) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EGRID1(i,j) = 0. EGRID2(i,j) = 0. EGRID5(i,j) = 0. @@ -3462,7 +3608,10 @@ SUBROUTINE MDLFLD CALL H2V(PINT(1:IM,JSTA_2L:JEND_2U,L), EGRID7) HCOUNT=0 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + if (EGRID4(I,J) 0.)THEN GRID2(I,J) = EGRID1(I,J)/EGRID2(I,J) ELSE @@ -3491,7 +3641,7 @@ SUBROUTINE MDLFLD CALL V2H(GRID2(1,JSTA_2L),EGRID2) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! EGRID1 is transport wind speed ! prevent floating overflow if either component is undefined @@ -3516,7 +3666,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3525,7 +3675,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -3543,7 +3693,7 @@ SUBROUTINE MDLFLD ! write(0,*) 'IM is: ', IM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF (PBLRI(I,J) /= SPVAL .and. EGRID3(I,J)/=SPVAL) then GRID1(I,J) = EGRID3(I,J)*PBLRI(I,J) @@ -3566,7 +3716,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3608,7 +3758,7 @@ SUBROUTINE MDLFLD ENDIF DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM LPBL(I,J)=LM if(ZINT(I,J,NINT(LMH(I,J))+1) 0) THEN !$omp parallel do private(i,j,jj) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM ! if(GUST(I,J) > 200. .and. gust(i,j)0) THEN - allocate(PBLREGIME(ista:iend,jsta_2l:jend_2u)) + allocate(PBLREGIME(im,jsta_2l:jend_2u)) CALL CALPBLREGIME(PBLREGIME) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PBLREGIME(I,J) ENDDO ENDDO @@ -3681,7 +3831,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3693,7 +3843,7 @@ SUBROUTINE MDLFLD ! IF(IGET(400)>0)THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM !Initialed as 'undetected'. Nov. 17, 2014, B. ZHOU: !changed from SPVAL to -5000. to distinguish missing grids and undetected ! GRID1(I,J) = SPVAL @@ -3724,7 +3874,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3760,7 +3910,7 @@ SUBROUTINE MDLFLD IF (LVLS(L,IGET(470))>0) THEN LL=LM-L+1 DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=gtg(i,j,LL) ENDDO ENDDO @@ -3771,7 +3921,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3779,7 +3929,7 @@ SUBROUTINE MDLFLD DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=catedr(i,j,LL) ENDDO ENDDO @@ -3790,14 +3940,14 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo endif DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=mwt(i,j,LL) ENDDO ENDDO @@ -3808,7 +3958,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3832,7 +3982,7 @@ SUBROUTINE MDLFLD icing_gfip = spval icing_gfis = spval DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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) @@ -3866,12 +4016,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=ista,iend +! do i=1,im ! grid1(i,j)=icing_gfip(i,j,l) ! end do ! end do ! ID(1:25) = 0 -! CALL GRIBIT(IGET(450),L,GRIDista,iend,JM) +! CALL GRIBIT(IGET(450),L,GRID1,IM,JM) ! end if ! end do ENDIF diff --git a/sorc/ncep_post.fd/MISCLN.f b/sorc/ncep_post.fd/MISCLN.f index ee8bfdf6f..3538cd00e 100644 --- a/sorc/ncep_post.fd/MISCLN.f +++ b/sorc/ncep_post.fd/MISCLN.f @@ -43,6 +43,8 @@ !! 19-09-03 J Meng - ADD CAPE related variables for HRRR !! 20-03-24 J Meng - remove grib1 !! 20-11-10 J Meng - USE UPP_PHYSICS MODULE +!! 21-03-25 E Colon - 3D-RTMA-specific SPC fields added as output +!! 21-04-01 J Meng - computation on defined points only !! !! USAGE: CALL MISCLN !! INPUT ARGUMENT LIST: @@ -81,18 +83,20 @@ SUBROUTINE MISCLN ! ! - use vrbls3d, only: pmid, uh, vh, t, zmid, pint, alpint, q, omga + use vrbls3d, only: pmid, uh, vh, t, zmid, zint, pint, alpint, q, omga use vrbls3d, only: catedr,mwt,gtg - use vrbls2d, only: pblh, cprate + use vrbls2d, only: pblh, cprate, fis, T500, T700, Z500, Z700,& + teql use masks, only: lmh - use params_mod, only: d00, h99999, h100, h1, h1m12, pq0, a2, a3, a4, & - rhmin, rgamog, tfrz, small - use ctlblk_mod, only: grib, cfld, fld_info, datapd, im, jsta, jend, jm, & + use params_mod, only: d00, d50, h99999, h100, h1, h1m12, pq0, a2, a3, a4, & + 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,ista,iend + jsta_2l, jend_2u, MODELNAME, SUBMODELNAME use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml use grib2_module, only: pset - use upp_physics, only: FPVSNEW, CALRH_PW, CALCAPE, CALCAPE2 + use upp_physics, only: FPVSNEW,CALRH_PW,CALCAPE,CALCAPE2,TVIRTUAL + use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -105,19 +109,27 @@ SUBROUTINE MISCLN real,parameter :: con_eps =con_rd/con_rv real,parameter :: con_epsm1 =con_rd/con_rv-1 real,parameter :: cpthresh =0.000004 + real,PARAMETER :: D1000=1000 + real,PARAMETER :: D1500=1500 + real,PARAMETER :: D2000=2000 + real,PARAMETER :: HCONST=42000000. + real,PARAMETER :: K2C=273.16 + ! ! DECLARE VARIABLES. ! LOGICAL NORTH, FIELD1,FIELD2 - LOGICAL, dimension(ista:iend,JSTA:JEND) :: DONE, DONE1 + LOGICAL, dimension(IM,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(ista:iend,jsta:jend) :: P1D, T1D, Q1D, U1D, V1D, SHR1D, Z1D, & + real,dimension(im,jsta:jend) :: P1D, T1D, Q1D, U1D, V1D, SHR1D, Z1D, & RH1D, EGRID1, EGRID2, EGRID3, EGRID4, & - EGRID5, EGRID6, EGRID7, EGRID8 + EGRID5, EGRID6, EGRID7, EGRID8, & + MLCAPE,MLCIN,MLLCL,MUCAPE,MUCIN,MUMIXR, & + FREEZELVL,MUQ1D,SLCL real, dimension(:,:,:),allocatable :: OMGBND, PWTBND, QCNVBND, & PBND, TBND, QBND, & UBND, VBND, RHBND, & @@ -137,28 +149,35 @@ SUBROUTINE MISCLN real, dimension(:,:), allocatable :: USHR1, VSHR1, USHR6, VSHR6, & MAXWP, MAXWZ, MAXWU, MAXWV, & MAXWT -! MAXWT, RHPW INTEGER,dimension(:,:),allocatable :: LLOW, LUPP - REAL, dimension(:,:),allocatable :: CANGLE + REAL, dimension(:,:),allocatable :: CANGLE,ESHR,UVECT,VVECT,& + EFFUST,EFFVST,FSHR,HTSFC,& + ESRH ! integer I,J,jj,L,ITYPE,ISVALUE,LBND,ILVL,IFD,ITYPEFDLVL(NFD), & - iget1, iget2, iget3 + iget1, iget2, iget3, LLMH 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 + ES1,ES2,QS1,QS2,RH1,RH2,ZSF,DEPTH(2),work1,work2,work3, & + SCINtmp,MUCAPEtmp,MUCINtmp,MLLCLtmp,ESHRtmp,MLCAPEtmp,STP,& + FSHRtmp,MLCINtmp,SLCLtmp,LAPSE,SHIP ! Variables introduced to allow FD levels from control file - Y Mao integer :: N,NFDCTL REAL, allocatable :: HTFDCTL(:) 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) ! !**************************************************************************** ! START MISCLN HERE. ! - allocate(USHR1(ista:iend,jsta_2l:jend_2u),VSHR1(ista:iend,jsta_2l:jend_2u), & - USHR6(ista:iend,jsta_2l:jend_2u),VSHR6(ista:iend,jsta_2l:jend_2u)) - allocate(UST(ista:iend,jsta_2l:jend_2u),VST(ista:iend,jsta_2l:jend_2u), & - HELI(ista:iend,jsta_2l:jend_2u,2)) + 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)) ! ! HELICITY AND STORM MOTION. iget1 = IGET(162) @@ -175,7 +194,7 @@ SUBROUTINE MISCLN IF (iget2 > 0) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = HELI(I,J,1) ENDDO ENDDO @@ -186,7 +205,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -196,7 +215,7 @@ SUBROUTINE MISCLN IF (iget3 > 0) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = HELI(I,J,2) ENDDO ENDDO @@ -207,7 +226,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -217,7 +236,7 @@ SUBROUTINE MISCLN IF (IGET(163) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = UST(I,J) ENDDO ENDDO @@ -227,7 +246,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -236,7 +255,7 @@ SUBROUTINE MISCLN IF (IGET(164) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = VST(I,J) ENDDO ENDDO @@ -246,7 +265,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -264,7 +283,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -279,11 +298,17 @@ SUBROUTINE MISCLN DEPTH = 6000.0 CALL CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) - +! 0-6 km shear magnitude +!$omp parallel do private(i,j) + DO J=JSTA,JEND + DO I=1,IM + 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,jj) +!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = USHR1(I,J) ENDDO ENDDO @@ -293,7 +318,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -302,7 +327,7 @@ SUBROUTINE MISCLN IF(IGET(431) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = VSHR1(I,J) ENDDO ENDDO @@ -312,7 +337,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -321,7 +346,7 @@ SUBROUTINE MISCLN IF(IGET(432) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = USHR6(I,J) ENDDO ENDDO @@ -331,7 +356,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -340,7 +365,7 @@ SUBROUTINE MISCLN IF(IGET(433) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = VSHR6(I,J) ENDDO ENDDO @@ -350,7 +375,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -377,7 +402,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=ista,iend + DO I=1,IM if(PMID(I,J,1) 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = P1D(I,J) ENDDO ENDDO @@ -414,7 +439,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -431,7 +456,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -442,7 +467,7 @@ SUBROUTINE MISCLN IF (IGET(177) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = Z1D(I,J) ENDDO ENDDO @@ -452,7 +477,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -463,7 +488,7 @@ SUBROUTINE MISCLN IF (IGET(055) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = T1D(I,J) ENDDO ENDDO @@ -473,7 +498,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -489,7 +514,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -500,7 +525,7 @@ SUBROUTINE MISCLN IF ((IGET(056) > 0).OR.(IGET(057) > 0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=U1D(I,J) GRID2(I,J)=V1D(I,J) ENDDO @@ -512,7 +537,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -523,7 +548,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -535,7 +560,7 @@ SUBROUTINE MISCLN IF (IGET(058) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = SHR1D(I,J) ENDDO ENDDO @@ -545,7 +570,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -564,7 +589,7 @@ SUBROUTINE MISCLN MAXWU(IM,jsta:jend), MAXWV(IM,jsta:jend),MAXWT(IM,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM MAXWP(I,J)=SPVAL MAXWZ(I,J)=SPVAL MAXWU(I,J)=SPVAL @@ -576,7 +601,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=ista,iend + loopI:DO I=1,IM DO L=1,LM IF (ABS(PMID(I,J,L)-SPVAL)<=SMALL .OR. & ABS(UH(I,J,L)-SPVAL)<=SMALL .OR. & @@ -599,7 +624,7 @@ SUBROUTINE MISCLN IF (IGET(173) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = MAXWP(I,J) ENDDO ENDDO @@ -609,7 +634,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -625,7 +650,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -635,7 +660,7 @@ SUBROUTINE MISCLN IF (IGET(174) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = MAXWZ(I,J) ENDDO ENDDO @@ -645,7 +670,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -656,7 +681,7 @@ SUBROUTINE MISCLN IF ((IGET(175) > 0).OR.(IGET(176) > 0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = MAXWU(I,J) GRID2(I,J) = MAXWV(I,J) ENDDO @@ -667,7 +692,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -676,7 +701,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -686,7 +711,7 @@ SUBROUTINE MISCLN IF (IGET(314) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=MAXWT(I,J) ENDDO ENDDO @@ -696,7 +721,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -803,7 +828,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = T7D(I,J,IFD) ENDDO ENDDO @@ -815,7 +840,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -829,7 +854,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -842,7 +867,7 @@ SUBROUTINE MISCLN IF (IGET(911)>0) THEN IF (LVLS(IFD,IGET(911))>0) THEN DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM if ( T7D(I,J,IFD) > 600 ) then GRID1(I,J)=SPVAL else @@ -880,7 +905,7 @@ SUBROUTINE MISCLN IF (work1 > 0 .or. work2 > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = Q7D(I,J,IFD) ENDDO ENDDO @@ -892,7 +917,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -906,7 +931,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -932,7 +957,7 @@ SUBROUTINE MISCLN IF (work1 > 0 .or. work2 > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = P7D(I,J,IFD) ENDDO ENDDO @@ -944,7 +969,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -958,7 +983,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -984,7 +1009,7 @@ SUBROUTINE MISCLN IF (work1 > 0 .or. work2 > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = ICINGFD(I,J,IFD) ENDDO ENDDO @@ -996,7 +1021,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1010,7 +1035,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1025,7 +1050,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(601))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=AERFD(I,J,IFD,1) ENDDO ENDDO @@ -1037,7 +1062,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1050,7 +1075,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(602))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=AERFD(I,J,IFD,2) ENDDO ENDDO @@ -1062,7 +1087,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1075,7 +1100,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(603))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=AERFD(I,J,IFD,3) ENDDO ENDDO @@ -1087,7 +1112,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1100,7 +1125,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(604))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=AERFD(I,J,IFD,4) ENDDO ENDDO @@ -1112,7 +1137,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1125,7 +1150,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(605))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=AERFD(I,J,IFD,5) ENDDO ENDDO @@ -1137,7 +1162,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1152,7 +1177,7 @@ SUBROUTINE MISCLN IF ((IGET(060)>0).OR.(IGET(061)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=U7D(I,J,IFD) GRID2(I,J)=V6D(I,J,IFD) ENDDO @@ -1166,7 +1191,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1182,7 +1207,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1195,7 +1220,7 @@ SUBROUTINE MISCLN IF ((IGET(576)>0).OR.(IGET(577)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = U7D(I,J,IFD) GRID2(I,J) = V6D(I,J,IFD) ENDDO @@ -1209,7 +1234,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1225,7 +1250,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1261,7 +1286,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(467))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=GTGFD(I,J,IFD) ENDDO ENDDO @@ -1272,7 +1297,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1298,7 +1323,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(468))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=CATFD(I,J,IFD) ENDDO ENDDO @@ -1309,7 +1334,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1335,7 +1360,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(469))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=MWTFD(I,J,IFD) ENDDO ENDDO @@ -1346,7 +1371,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1374,8 +1399,9 @@ SUBROUTINE MISCLN IF (IGET(062)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=Z1D(I,J) + IF (SUBMODELNAME == 'RTMA') FREEZELVL(I,J)=GRID1(I,J) ENDDO ENDDO CALL BOUND (GRID1,D00,H99999) @@ -1385,7 +1411,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1396,7 +1422,7 @@ SUBROUTINE MISCLN IF (IGET(063)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RH1D(I,J) ENDDO ENDDO @@ -1408,7 +1434,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1419,7 +1445,7 @@ SUBROUTINE MISCLN IF (IGET(753)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = P1D(I,J) ENDDO ENDDO @@ -1429,7 +1455,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1445,7 +1471,7 @@ SUBROUTINE MISCLN IF (IGET(165)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1456,7 +1482,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1464,11 +1490,12 @@ SUBROUTINE MISCLN END IF ! HIGHEST FREEZING LEVEL RELATIVE HUMIDITY - IF (IGET(350)>0)THEN + IF (IGET(350)>0)THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J)=RH1D(I,J)*100. + DO I=1,IM + IF(RH1D(I,J) < spval) GRID1(I,J)=RH1D(I,J)*100. ENDDO ENDDO CALL BOUND (GRID1,H1,H100) @@ -1478,7 +1505,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1489,7 +1516,7 @@ SUBROUTINE MISCLN IF (IGET(756)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = P1D(I,J) ENDDO ENDDO @@ -1499,7 +1526,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1517,7 +1544,7 @@ SUBROUTINE MISCLN IF (IGET(776)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1528,7 +1555,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1537,10 +1564,11 @@ SUBROUTINE MISCLN ! HIGHEST -10C ISOTHERM RELATIVE HUMIDITY IF (IGET(777)>0)THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J)=RH1D(I,J)*100. + DO I=1,IM + IF(RH1D(I,J) < spval) GRID1(I,J)=RH1D(I,J)*100. ENDDO ENDDO CALL BOUND (GRID1,H1,H100) @@ -1550,7 +1578,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1561,7 +1589,7 @@ SUBROUTINE MISCLN IF (IGET(778)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=P1D(I,J) ENDDO ENDDO @@ -1571,7 +1599,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1589,7 +1617,7 @@ SUBROUTINE MISCLN IF (IGET(779)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1600,7 +1628,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1609,10 +1637,11 @@ SUBROUTINE MISCLN ! HIGHEST -20C ISOTHERM RELATIVE HUMIDITY IF (IGET(780)>0)THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J)=RH1D(I,J)*100. + DO I=1,IM + IF(RH1D(I,J) < spval) GRID1(I,J)=RH1D(I,J)*100. ENDDO ENDDO CALL BOUND (GRID1,H1,H100) @@ -1622,7 +1651,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1633,7 +1662,7 @@ SUBROUTINE MISCLN IF (IGET(781)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=P1D(I,J) ENDDO ENDDO @@ -1643,7 +1672,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1685,7 +1714,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EGRID2(i,j) = SPVAL ENDDO ENDDO @@ -1699,7 +1728,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(067))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PBND(I,J,LBND) ENDDO ENDDO @@ -1710,7 +1739,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1723,7 +1752,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(068))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=TBND(I,J,LBND) ENDDO ENDDO @@ -1734,7 +1763,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1753,7 +1782,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1766,7 +1795,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(072))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=RHBND(I,J,LBND) ENDDO ENDDO @@ -1779,7 +1808,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1799,7 +1828,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1812,7 +1841,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(071))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=QBND(I,J,LBND) ENDDO ENDDO @@ -1824,7 +1853,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1837,7 +1866,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(088))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = QCNVBND(I,J,LBND) ENDDO ENDDO @@ -1848,7 +1877,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1871,7 +1900,7 @@ SUBROUTINE MISCLN IF(FIELD1.OR.FIELD2)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = UBND(I,J,LBND) GRID2(I,J) = VBND(I,J,LBND) ENDDO @@ -1886,7 +1915,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1902,7 +1931,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1916,7 +1945,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(090))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = OMGBND(I,J,LBND) ENDDO ENDDO @@ -1927,7 +1956,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1940,7 +1969,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(089))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PWTBND(I,J,LBND) ENDDO ENDDO @@ -1952,7 +1981,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1973,7 +2002,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1983,7 +2012,7 @@ SUBROUTINE MISCLN IF(IGET(031)>0 .or. IGET(573)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EGRID2(I,J) = MIN(EGRID2(I,J),GRID1(I,J)) END DO END DO @@ -1998,7 +2027,7 @@ SUBROUTINE MISCLN ! IF (IGET(031)>0 .OR. IGET(573)>0 ) THEN ! DO J=JSTA,JEND -! DO I=ista,iend +! DO I=1,IM ! EGRID1(I,J) = H99999 ! EGRID2(I,J) = H99999 ! ENDDO @@ -2008,14 +2037,14 @@ SUBROUTINE MISCLN ! CALL OTLFT(PBND(1,1,LBND),TBND(1,1,LBND), & ! QBND(1,1,LBND),EGRID2) ! DO J=JSTA,JEND -! DO I=ista,iend +! DO I=1,IM ! EGRID1(I,J)=AMIN1(EGRID1(I,J),EGRID2(I,J)) ! ENDDO ! ENDDO ! 50 CONTINUE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J)=EGRID2(I,J) ENDDO ENDDO @@ -2036,7 +2065,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2074,7 +2103,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 ENDDO @@ -2085,7 +2114,8 @@ SUBROUTINE MISCLN QBND(1,jsta,LBND),EGRID1) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF (EGRID1(I,J) > EGRID2(I,J)) THEN EGRID2(I,J) = EGRID1(I,J) LB2(I,J) = LVLBND(I,J,LBND) @@ -2106,7 +2136,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -2118,7 +2148,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2130,7 +2160,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -2139,7 +2169,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -2151,7 +2181,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2164,7 +2194,7 @@ SUBROUTINE MISCLN IF(IGET(221) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PBLH(I,J) ENDDO ENDDO @@ -2174,7 +2204,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2187,10 +2217,11 @@ SUBROUTINE MISCLN CALL CALLCL(PBND(1,jsta,1),TBND(1,jsta,1), & QBND(1,jsta,1),EGRID1,EGRID2) IF (IGET(109)>0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = EGRID2(I,J) + DO I=1,IM + IF(TBND(I,J,1) < spval) GRID1(I,J) = EGRID2(I,J) ENDDO ENDDO if(grib=='grib2') then @@ -2199,17 +2230,18 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo endif ENDIF IF (IGET(110)>0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = EGRID1(I,J) + DO I=1,IM + IF(TBND(I,J,1) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO if(grib=='grib2') then @@ -2218,7 +2250,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2242,7 +2274,7 @@ SUBROUTINE MISCLN IF (IGET(097)>0.OR.IGET(098)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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 @@ -2252,7 +2284,7 @@ SUBROUTINE MISCLN !!$omp parallel do private(fac1,fac2,pkl1,pku1,t78483,t89671) DO L=2,LM DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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= ', & @@ -2276,7 +2308,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=ista,iend + DO I=1,IM 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)) @@ -2343,10 +2375,11 @@ SUBROUTINE MISCLN ! ! SIGMA 0.89671 TEMPERATURE IF (IGET(097) > 0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = T89671(I,J) + DO I=1,IM + 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) ENDDO @@ -2358,7 +2391,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2367,10 +2400,11 @@ SUBROUTINE MISCLN ! ! SIGMA 0.78483 TEMPERATURE IF (IGET(098)>0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = T78483(I,J) + DO I=1,IM + IF(T(I,J,LM) < spval) GRID1(I,J) = T78483(I,J) ENDDO ENDDO if(grib=='grib2') then @@ -2380,7 +2414,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2403,7 +2437,7 @@ SUBROUTINE MISCLN IF (IGET(091)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PBND(I,J,1) ENDDO ENDDO @@ -2413,7 +2447,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2424,7 +2458,7 @@ SUBROUTINE MISCLN IF (IGET(092)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = TBND(I,J,1) ENDDO ENDDO @@ -2435,7 +2469,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2446,7 +2480,7 @@ SUBROUTINE MISCLN IF (IGET(093)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = QBND(I,J,1) ENDDO ENDDO @@ -2458,7 +2492,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2469,7 +2503,7 @@ SUBROUTINE MISCLN IF (IGET(094)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RHBND(I,J,1) ENDDO ENDDO @@ -2482,7 +2516,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2493,7 +2527,7 @@ SUBROUTINE MISCLN IF ((IGET(095)>0).OR.(IGET(096)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = UBND(I,J,1) GRID2(I,J) = VBND(I,J,1) ENDDO @@ -2506,7 +2540,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2520,7 +2554,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2555,7 +2589,7 @@ SUBROUTINE MISCLN IF (IGET(066)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RH3310(I,J) ENDDO ENDDO @@ -2568,7 +2602,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2581,7 +2615,7 @@ SUBROUTINE MISCLN IF (IGET(081)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RH6610(I,J) ENDDO ENDDO @@ -2594,7 +2628,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2605,7 +2639,7 @@ SUBROUTINE MISCLN IF (IGET(082)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RH3366(I,J) ENDDO ENDDO @@ -2618,7 +2652,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2629,7 +2663,7 @@ SUBROUTINE MISCLN IF (IGET(104)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = PW3310(I,J) ENDDO ENDDO @@ -2641,7 +2675,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2665,7 +2699,7 @@ SUBROUTINE MISCLN IF (IGET(099)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RH4710(I,J) ENDDO ENDDO @@ -2678,7 +2712,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2689,7 +2723,7 @@ SUBROUTINE MISCLN IF (IGET(100)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RH4796(I,J) ENDDO ENDDO @@ -2702,7 +2736,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2713,7 +2747,7 @@ SUBROUTINE MISCLN IF (IGET(101)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RH1847(I,J) ENDDO ENDDO @@ -2726,7 +2760,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2737,7 +2771,7 @@ SUBROUTINE MISCLN IF (IGET(102)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = RH8498(I,J) ENDDO ENDDO @@ -2750,7 +2784,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2760,10 +2794,11 @@ SUBROUTINE MISCLN ! SIGMA 0.85000-1.00000 MOISTURE CONVERGENCE. IF (IGET(103)>0) THEN ! CONVERT TO DIVERGENCE FOR GRIB + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = -1.0*QM8510(I,J) + DO I=1,IM + IF(QM8510(I,J) < spval) GRID1(I,J) = -1.0*QM8510(I,J) ENDDO ENDDO if(grib=='grib2') then @@ -2773,7 +2808,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2792,10 +2827,11 @@ SUBROUTINE MISCLN ! ! SIGMA 0.44-1.00 MEAN RELATIVE HUMIIDITY. IF (IGET(318)>0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = RH4410(I,J)*100. + DO I=1,IM + IF(RH4410(I,J) < spval) GRID1(I,J) = RH4410(I,J)*100. ENDDO ENDDO CALL BOUND(GRID1,D00,H100) @@ -2806,7 +2842,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2815,10 +2851,11 @@ SUBROUTINE MISCLN ! ! SIGMA 0.72-0.94 MEAN RELATIVE HUMIIDITY. IF (IGET(319)>0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = RH7294(I,J)*100. + DO I=1,IM + IF(RH7294(I,J) < spval) GRID1(I,J) = RH7294(I,J)*100. ENDDO ENDDO CALL BOUND(GRID1,D00,H100) @@ -2829,7 +2866,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2838,10 +2875,11 @@ SUBROUTINE MISCLN ! ! SIGMA 0.44-0.72 MEAN RELATIVE HUMIIDITY. IF (IGET(320)>0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J)=RH4472(I,J)*100. + DO I=1,IM + IF(RH4472(I,J) < spval) GRID1(I,J)=RH4472(I,J)*100. ENDDO ENDDO CALL BOUND(GRID1,D00,H100) @@ -2852,7 +2890,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2864,10 +2902,10 @@ SUBROUTINE MISCLN ! GFS computes sigma=0.9950 T, THETA, U, V from lowest two model level fields IF ( (IGET(321)>0).OR.(IGET(322)>0).OR. & (IGET(323)>0).OR.(IGET(324)>0).OR. & - (IGET(325)>0).OR.(IGET(326)>0) ) THEN + (IGET(325)>0).OR.(IGET(326)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM 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)) @@ -2885,9 +2923,11 @@ SUBROUTINE MISCLN END DO ! Temperature IF (IGET(321)>0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(T(I,J,LM)0) THEN + GRID2=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(T(I,J,LM)0) THEN + GRID1=spval !$omp parallel do private(i,j,es1,qs1,rh1,es2,qs2,rh2) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(PMID(I,J,LM)0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(UH(I,J,LM)0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(VH(I,J,LM)0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(OMGA(I,J,LM)0) THEN + IF (IGET(582)>0) THEN ! dong add missing value for cape GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) + DO I=1,IM + IF(T1D(I,J) < spval) THEN + GRID1(I,J) = EGRID1(I,J) + IF (SUBMODELNAME == 'RTMA') MLCAPE(I,J)=GRID1(I,J) + ENDIF ENDDO ENDDO - CALL BOUND(GRID1,D00,H99999) if(grib=='grib2') then cfld=cfld+1 @@ -3087,7 +3141,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3098,7 +3152,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -3107,8 +3161,11 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) + DO I=1,IM + IF(T1D(I,J) < spval) THEN + GRID1(I,J) = - GRID1(I,J) + IF (SUBMODELNAME == 'RTMA') MLCIN(I,J) = GRID1(I,J) + ENDIF ENDDO ENDDO ! @@ -3119,36 +3176,37 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo endif - ENDIF ENDIF - + ! MIXED LAYER LIFTING CONDENSATION PRESSURE AND HEIGHT. ! EGRID1 IS LCL PRESSURE. EGRID2 IS LCL HEIGHT. ! -! IF ( (IGET(109)>0).OR.(IGET(110)>0) ) THEN -! CALL CALLCL(P1D,T1D,Q1D,EGRID1,EGRID2) -! IF (IGET(109)>0) THEN -! DO J=JSTA,JEND -! DO I=ista,iend -! GRID1(I,J)=EGRID2(I,J) -! ENDDO -! ENDDO + IF ( (IGET(109)>0).OR.(IGET(110)>0) ) THEN + CALL CALLCL(P1D,T1D,Q1D,EGRID1,EGRID2) + IF (IGET(109)>0) THEN + GRID1=spval + DO J=JSTA,JEND + DO I=1,IM + IF(T1D(I,J) < spval) GRID1(I,J)=EGRID2(I,J) + IF (SUBMODELNAME == 'RTMA') MLLCL(I,J) = GRID1(I,J) + ENDDO + ENDDO ! ! ID(1:25) = 0 ! ! CALL GRIBIT(IGET(109),1, -! X GRIDista,iend,JM) -! ENDIF +! X GRID1,IM,JM) + ENDIF ! ! IF (IGET(110)>0) THEN ! DO J=JSTA,JEND -! DO I=ista,iend +! DO I=1,IM ! GRID1(I,J)=EGRID1(I,J) ! ENDDO ! ENDDO @@ -3156,9 +3214,9 @@ SUBROUTINE MISCLN ! ID(1:25) = 0 ! ! CALL GRIBIT(IGET(110),1, -! X GRIDista,iend,JM) +! X GRID1,IM,JM) ! ENDIF -! ENDIF + ENDIF ! ! MOST UNSTABLE CAPE-LOWEST 300 MB ! @@ -3185,7 +3243,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 ENDDO @@ -3194,17 +3252,23 @@ SUBROUTINE MISCLN DPBND = 300.E2 CALL CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,LB2,EGRID1, & EGRID2,EGRID3,EGRID4,EGRID5) -! + IF (SUBMODELNAME == 'RTMA') MUMIXR(I,J) = Q1D(I,J) IF (IGET(584)>0) THEN ! dong add missing value to cin GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) + DO I=1,IM + IF(T1D(I,J) < spval) THEN + GRID1(I,J) = EGRID1(I,J) + IF (SUBMODELNAME == 'RTMA') MUCAPE(I,J) = GRID1(I,J) + ENDIF ENDDO ENDDO CALL BOUND(GRID1,D00,H99999) +! IF (SUBMODELNAME == 'RTMA') THEN +! CALL BOUND(MUCAPE,D00,H99999) +! ENDIF if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(584)) @@ -3212,7 +3276,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3225,15 +3289,20 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO - CALL BOUND(GRID1,D00,H99999) DO J=JSTA,JEND - DO I=ista,iend - IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) + DO I=1,IM + IF(T1D(I,J) < spval) THEN + GRID1(I,J) = - GRID1(I,J) + IF (SUBMODELNAME == 'RTMA') THEN + MUCAPE(I,J) = GRID1(I,J) + MUQ1D(I,J) = Q1D(I,J) + ENDIF + ENDIF ENDDO ENDDO if(grib=='grib2') then @@ -3243,7 +3312,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3253,10 +3322,11 @@ SUBROUTINE MISCLN ! EQUILLIBRIUM HEIGHT IF (IGET(443)>0) THEN + GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = EGRID4(I,J) + DO I=1,IM + IF(T1D(I,J) < spval) GRID1(I,J) = EGRID4(I,J) ENDDO ENDDO if(grib=='grib2') then @@ -3266,20 +3336,43 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo endif ENDIF +!Equilibrium Temperature + IF (IGET(982)>0) THEN + DO J=JSTA,JEND + DO I=1,IM + GRID1(I,J) = TEQL(I,J) + ENDDO + ENDDO + if(grib=='grib2') then + 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) + do j=1,jend-jsta+1 + jj = jsta+j-1 + do i=1,im + datapd(i,j,cfld) = GRID1(i,jj) + enddo + enddo + endif + ENDIF + + ! PRESSURE OF LEVEL FROM WHICH 300 MB MOST UNSTABLE CAPE ! PARCEL WAS LIFTED (eq. PRESSURE OF LEVEL OF HIGHEST THETA-E) IF (IGET(246)>0) THEN + GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = EGRID3(I,J) + DO I=1,IM + IF(T1D(I,J) < spval) GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO CALL BOUND(GRID1,D00,H99999) @@ -3292,7 +3385,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3301,14 +3394,17 @@ SUBROUTINE MISCLN ! GENERAL THUNDER PARAMETER ??? 458 ??? IF (IGET(444)>0) THEN + GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM + IF(CPRATE(I,J) < spval) THEN IF (CPRATE(I,J) > PTHRESH) THEN GRID1(I,J) = EGRID5(I,J) ELSE GRID1(I,J) = 0 ENDIF + ENDIF ENDDO ENDDO CALL BOUND(GRID1,D00,H99999) @@ -3319,7 +3415,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3353,7 +3449,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 EGRID3(I,J) = -H99999 @@ -3365,7 +3461,7 @@ SUBROUTINE MISCLN ! ENDDO ! ENDDO ! DO J=JSTA,JEND -! DO I=ista,iend +! DO I=1,IM LB2(I,J) = (LVLBND(I,J,1) + LVLBND(I,J,2) + & LVLBND(I,J,3))/3 P1D(I,J) = (PBND(I,J,1) + PBND(I,J,2) + PBND(I,J,3))/3 @@ -3387,7 +3483,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -3399,7 +3495,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3411,7 +3507,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -3420,7 +3516,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -3432,7 +3528,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3442,10 +3538,11 @@ SUBROUTINE MISCLN ! LFC HEIGHT IF (IGET(952)>0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = EGRID3(I,J) + DO I=1,IM + IF(T1D(I,J) < spval) GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO CALL BOUND(GRID1,D00,H99999) @@ -3456,7 +3553,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3465,8 +3562,6 @@ SUBROUTINE MISCLN ! EFFECTIVE STORM RELATIVE HELICITY AND STORM MOTION. - 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)) allocate(LLOW(IM,jsta_2l:jend_2u),LUPP(IM,jsta_2l:jend_2u), & @@ -3485,7 +3580,7 @@ SUBROUTINE MISCLN DEPTH(2) = 1000.0 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM LLOW(I,J) = INT(EGRID4(I,J)) LUPP(I,J) = INT(EGRID5(I,J)) ENDDO @@ -3497,7 +3592,7 @@ SUBROUTINE MISCLN IF (iget2 > 0) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM GRID1(I,J) = HELI(I,J,1) ! GRID1(I,J) = HELI(I,J,2) ENDDO @@ -3509,7 +3604,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3518,13 +3613,562 @@ SUBROUTINE MISCLN ENDIF !953 + IF (SUBMODELNAME == 'RTMA') THEN !Start RTMA block + +!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)) + +!get surface height + IF(gridtype == 'E')THEN + JVN = 1 + JVS = -1 + do J=JSTA,JEND + IVE(J) = MOD(J,2) + IVW(J) = IVE(J)-1 + enddo + ISTART = 2 + ISTOP = IM-1 + JSTART = JSTA_M + JSTOP = JEND_M + ELSE IF(gridtype == 'B')THEN + JVN = 1 + JVS = 0 + do J=JSTA,JEND + IVE(J)=1 + IVW(J)=0 + enddo + ISTART = 2 + ISTOP = IM-1 + JSTART = JSTA_M + JSTOP = JEND_M + ELSE + JVN = 0 + JVS = 0 + do J=JSTA,JEND + IVE(J) = 0 + IVW(J) = 0 + enddo + ISTART = 1 + ISTOP = IM + JSTART = JSTA + JSTOP = JEND + END IF + + IF(gridtype /= 'A') CALL EXCH(FIS(1:IM,JSTA:JEND)) + DO J=JSTART,JSTOP + DO I=ISTART,ISTOP + IE = I+IVE(J) + IW = I+IVW(J) + JN = J+JVN + JS = J+JVS + IF (gridtype=='B')THEN + HTSFC(I,J)=(0.25/g)*(FIS(IW,J)+FIS(IE,J)+FIS(I,JN)+FIS(IE,JN)) + ELSE + HTSFC(I,J)=(0.25/g)*(FIS(IW,J)+FIS(IE,J)+FIS(I,JN)+FIS(I,JS)) + ENDIF + ENDDO + ENDDO + +!Height of effbot + IF (IGET(979)>0) THEN + GRID1=spval + DO J=JSTA,JEND + DO I=1,IM + IF(ZINT(I,J,LLOW(I,J))0) THEN + GRID1=spval + DO J=JSTA,JEND + DO I=1,IM + IF(ZINT(I,J,LUPP(I,J))0) THEN + GRID1=spval + DO J=JSTA,JEND + DO I=1,IM + IF(LLOW(I,J)0) THEN + GRID1=spval + DO J=JSTA,JEND + DO I=1,IM + IF(LLOW(I,J)0) THEN + GRID1=spval + DO J=JSTA,JEND + DO I=1,IM + IF(UVECT(I,J)0) THEN + GRID1=spval + DO J=JSTA,JEND + DO I=1,IM + IF(LLOW(I,J)0) THEN + GRID1=spval + DO J=JSTA,JEND + DO I=1,IM + IF(LLOW(I,J)0) THEN + GRID1=spval + DO J=JSTA,JEND + DO I=1,IM + IF(LLOW(I,J)0) THEN + DO J=JSTA,JEND + DO I=1,IM + IF (MLLCL(I,J)>D2000) THEN + MLLCLtmp=D00 + ELSEIF (MLLCL(I,J)30.0) THEN + ESHRtmp=1.5 + ELSE + ESHRtmp=(ESHR(I,J)/20.) + ENDIF + IF (MLCIN(I,J)>-50.) THEN + MLCINtmp=1.0 + ELSEIF (MLCIN(I,J)<-200.) THEN + MLCINtmp=D00 + ELSE + MLCINtmp=(200.+MLCIN(I,J))/150. + ENDIF + STP=(MLCAPE(I,J)/D1500)*MLLCLtmp*(ESRH(I,J)/150.)*& + ESHRtmp*MLCINtmp + GRID1(I,J) = SPVAL + IF(LLOW(I,J)0) THEN + GRID1(I,J)=STP + ELSE + GRID1(I,J)=D00 + ENDIF + ENDIF + ENDDO + ENDDO + if(grib=='grib2') then + cfld=cfld+1 + fld_info(cfld)%ifld=IAVBLFLD(IGET(989)) + fld_info(cfld)%lvl=LVLSXML(1,IGET(989)) +! $omp parallel do private(i,j,jj) + do j=1,jend-jsta+1 + jj = jsta+j-1 + do i=1,im + datapd(i,j,cfld) = GRID1(i,jj) + enddo + enddo + endif + ENDIF + +!Fixed Layer Tornado Parameter + IF (IGET(990)>0) THEN + DO J=JSTA,JEND + DO I=1,IM + LLMH = NINT(LMH(I,J)) + P1D(I,J) = PMID(I,J,LLMH) + T1D(I,J) = T(I,J,LLMH) + Q1D(I,J) = Q(I,J,LLMH) + ENDDO + ENDDO + CALL CALLCL(P1D,T1D,Q1D,EGRID1,EGRID2) + DO J=JSTA,JEND + DO I=1,IM + SLCL(I,J)=EGRID2(I,J) + ENDDO + ENDDO + ITYPE = 1 + DPBND = 10.E2 + dummy = 0. + idummy = 0 + CALL CALCAPE(ITYPE,DPBND,dummy,dummy,dummy,& + idummy,EGRID1,EGRID2,& + EGRID3,dummy,dummy) + + DO J=JSTA,JEND + DO I=1,IM + IF (SLCL(I,J)>D2000) THEN + SLCLtmp=D00 + ELSEIF (SLCL(I,J)<=D1000) THEN + SLCLtmp=1.0 + ELSE + SLCLtmp=((D2000-SLCL(I,J))/D1000) + ENDIF + IF (FSHR(I,J)<12.5) THEN + FSHRtmp=D00 + ELSEIF (FSHR(I,J)>30.0) THEN + FSHRtmp=1.5 + ELSE + FSHRtmp=(FSHR(I,J)/20.) + ENDIF + IF (EGRID2(I,J)>-50.) THEN + SCINtmp=1.0 + ELSEIF (EGRID2(I,J)<-200.) THEN + SCINtmp=D00 + ELSE + SCINtmp=((200.+EGRID2(I,J)/150.)) + ENDIF + STP=(EGRID1(I,J)/D1500)*SLCLtmp*(HELI(I,J,2)/150.)*& + FSHRtmp*SCINtmp + GRID1(I,J) = spval + IF(T1D(I,J) < spval) THEN + IF (STP>0) THEN + GRID1(I,J)=STP + ELSE + GRID1(I,J)=D00 + ENDIF + ENDIF + ENDDO + ENDDO + if(grib=='grib2') then + 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) + do j=1,jend-jsta+1 + jj = jsta+j-1 + do i=1,im + datapd(i,j,cfld) = GRID1(i,jj) + enddo + enddo + endif + ENDIF + +!Effective Layer Supercell Parameter + IF (IGET(991)>0) THEN + DO J=JSTA,JEND + DO I=1,IM + IF (ESHR(I,J)<10.) THEN + ESHRtmp=D00 + ELSEIF (ESHR(I,J)>20.0) THEN + ESHRtmp=1 + ELSE + ESHRtmp=(ESHR(I,J)/20.) + ENDIF + IF (MUCIN(I,J)>-40.) THEN + MUCINtmp=1.0 + ELSE + MUCINtmp=(-40./MUCIN(I,J)) + ENDIF + STP=(MUCAPE(I,J)/D1000)*(ESRH(I,J)/50.)*& + ESHRtmp*MUCINtmp + GRID1(I,J) = spval + IF(T1D(I,J) < spval) THEN + IF (STP>0) THEN + GRID1(I,J)=STP + ELSE + GRID1(I,J)=D00 + ENDIF + ENDIF + ENDDO + ENDDO + if(grib=='grib2') then + 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) + do j=1,jend-jsta+1 + jj = jsta+j-1 + do i=1,im + datapd(i,j,cfld) = GRID1(i,jj) + enddo + enddo + endif + ENDIF + +!Mixed Layer (100 mb) Virtual LFC + + IF (IGET(992)>0) THEN +!$omp parallel do private(i,j) + DO J=JSTA,JEND + DO I=1,IM + EGRID1(I,J) = -H99999 + EGRID2(I,J) = -H99999 + EGRID3(I,J) = -H99999 + EGRID4(I,J) = -H99999 + EGRID5(I,J) = -H99999 + EGRID6(I,J) = -H99999 + EGRID7(I,J) = -H99999 + EGRID8(I,J) = -H99999 + LB2(I,J) = (LVLBND(I,J,1) + LVLBND(I,J,2) + & + LVLBND(I,J,3))/3 + P1D(I,J) = (PBND(I,J,1) + PBND(I,J,2) + PBND(I,J,3))/3 + T1D(I,J) = (TVIRTUAL(TBND(I,J,1),QBND(I,J,1)) + & + TVIRTUAL(TBND(I,J,2),QBND(I,J,2)) + & + TVIRTUAL(TBND(I,J,3),QBND(I,J,3)))/3 + Q1D(I,J) = (QBND(I,J,1) + QBND(I,J,2) + QBND(I,J,3))/3 + ENDDO + ENDDO + + DPBND = 0. + ITYPE = 2 +! EGRID3 is Virtual LFC + CALL CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,LB2, & + EGRID1,EGRID2,EGRID3,EGRID4,EGRID5, & + EGRID6,EGRID7,EGRID8) + GRID1=spval + DO J=JSTA,JEND + DO I=1,IM + IF(T1D(I,J) < spval) GRID1(I,J) = EGRID3(I,J) + ENDDO + ENDDO + CALL BOUND(GRID1,D00,H99999) + if(grib=='grib2') then + 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) + do j=1,jend-jsta+1 + jj = jsta+j-1 + do i=1,im + datapd(i,j,cfld) = GRID1(i,jj) + enddo + enddo + endif + ENDIF !992 + + + IF (IGET(763)>0) THEN +!$omp parallel do private(i,j) +! EGRID3 is Virtual LFC + DO J=JSTA,JEND + DO I=1,IM + GRID1(I,J) = Q1D(I,J) + ENDDO + ENDDO + if(grib=='grib2') then + 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) + do j=1,jend-jsta+1 + jj = jsta+j-1 + do i=1,im + datapd(i,j,cfld) = GRID1(i,jj) + enddo + enddo + endif + ENDIF + +!Hail parameter + IF (IGET(993)>0) THEN + GRID1=spval + DO J=JSTA,JEND + DO I=1,IM + IF(T700(I,J) < spval .and. T500(I,J) < spval .and.& + Z700(I,J) < spval .and. Z500(I,J) < spval .and.& + MUCAPE(I,J) < spval .and. MUQ1D(I,J) < spval .and. FSHR(I,J) < spval) THEN + 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 + SHIP=SHIP*(MUCAPE(I,J)/1300.) + ENDIF + IF (LAPSE < 5.8)THEN + SHIP=SHIP*(LAPSE/5.8) + ENDIF + IF (FREEZELVL(I,J) < 2400.)THEN + SHIP=SHIP*(FREEZELVL(I,J)/2400.) + ENDIF + GRID1(I,J)=SHIP + ENDIF + ENDDO + ENDDO + if(grib=='grib2') then + 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) + do j=1,jend-jsta+1 + jj = jsta+j-1 + do i=1,im + datapd(i,j,cfld) = GRID1(i,jj) + enddo + enddo + endif + ENDIF + + ENDIF !END RTMA BLOCK + + ! Critical Angle IF (IGET(957)>0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = CANGLE(I,J) + DO I=1,IM + 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. ! ENDIF @@ -3537,7 +4181,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3547,10 +4191,11 @@ SUBROUTINE MISCLN ! Dendritic Layer Depth, -17C < T < -12C IF (IGET(955)>0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = EGRID7(I,J) + DO I=1,IM + IF(T1D(I,J) < spval ) GRID1(I,J) = EGRID7(I,J) ENDDO ENDDO CALL BOUND(GRID1,D00,H99999) @@ -3561,7 +4206,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3571,10 +4216,11 @@ SUBROUTINE MISCLN ! Enhanced Stretching Potential IF (IGET(956)>0) THEN + GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend - GRID1(I,J) = EGRID8(I,J) + DO I=1,IM + IF(T1D(I,J) < spval ) GRID1(I,J) = EGRID8(I,J) ENDDO ENDDO CALL BOUND(GRID1,D00,H99999) @@ -3585,7 +4231,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3596,7 +4242,7 @@ SUBROUTINE MISCLN ITYPE = 1 ! DO J=JSTA,JEND - ! DO I=ista,iend + ! DO I=1,IM ! LB2(I,J) = (LVLBND(I,J,1) + LVLBND(I,J,2) + & ! LVLBND(I,J,3))/3 ! P1D(I,J) = (PBND(I,J,1) + PBND(I,J,2) + PBND(I,J,3))/3 @@ -3614,7 +4260,7 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=ista,iend + DO I=1,IM IF(T1D(I,J) < spval) GRID1(I,J) = -EGRID6(I,J) ENDDO ENDDO @@ -3626,7 +4272,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3644,7 +4290,14 @@ SUBROUTINE MISCLN if (allocated(llow)) deallocate(llow) if (allocated(lupp)) deallocate(lupp) if (allocated(cangle))deallocate(cangle) - + if (allocated(effust))deallocate(effust) + if (allocated(effvst))deallocate(effvst) + if (allocated(eshr)) deallocate(eshr) + if (allocated(uvect)) deallocate(uvect) + if (allocated(vvect)) deallocate(vvect) + if (allocated(esrh)) deallocate(esrh) + if (allocated(htsfc)) deallocate(htsfc) + if (allocated(fshr)) deallocate(fshr) ENDIF if (allocated(pbnd)) deallocate(pbnd) @@ -3667,7 +4320,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 583602164..920f78e18 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -13,8 +13,6 @@ !! 02-06-19 MIKE BALDWIN - WRF VERSION !! 11-12-16 SARAH LU - MODIFIED TO INITIALIZE AEROSOL FIELDS !! 12-01-07 SARAH LU - MODIFIED TO INITIALIZE AIR DENSITY/LAYER THICKNESS -!! 3/28/2021 George Vandenberghe. Added ista and iend variables to -!! determine lower and upper bounds for a 2D decomposition !! !! USAGE: CALL MPI_FIRST !! INPUT ARGUMENT LIST: @@ -87,8 +85,8 @@ SUBROUTINE MPI_FIRST() use ctlblk_mod, only: me, num_procs, jm, jsta, jend, jsta_m, jsta_m2, & jend_m, jend_m2, iup, idn, icnt, im, idsp, jsta_2l, jend_2u, & jvend_2u, lm, lp1, jsta_2l, jend_2u, nsoil, nbin_du, nbin_ss, & - nbin_bc, nbin_oc, nbin_su, & - ista,iend + nbin_bc, nbin_oc, nbin_su + ! ! use params_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -118,13 +116,7 @@ SUBROUTINE MPI_FIRST() ! ! global loop ranges ! -! Using J dimension and number of ranks obtain beginning and end J -! limits for each rank. -! 2d also obtain beginning and end I limits for each rank (using -! para_range2) -! -!gwv call para_range(1,jm,num_procs,me,jsta,jend) - call para_range2(1,jm,1,im,num_procs,me,jsta,jend,ista,iend) + call para_range(1,jm,num_procs,me,jsta,jend) jsta_m = jsta jsta_m2 = jsta jend_m = jend @@ -157,8 +149,7 @@ SUBROUTINE MPI_FIRST() ! counts, disps for gatherv and scatterv ! do i = 0, num_procs - 1 - call para_range2(1,jm,1,im,num_procs,i,jsx,jex,ista,iend) -!gwv delete after 2D support is validated call para_range(1,jm,num_procs,i,jsx,jex) + 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 @@ -181,8 +172,8 @@ SUBROUTINE MPI_FIRST() ! ! FROM VRBLS3D ! - print *, 'GWVX me, jsta_2l, jend_2u = ',me,jsta_2l, jend_2u, & + print *, ' me, jsta_2l, jend_2u = ',me,jsta_2l, jend_2u, & 'jvend_2u=',jvend_2u,'im=',im,'jm=',jm,'lm=',lm, & - 'lp1=',lp1,' ista and iend= ',ista,iend + 'lp1=',lp1 end diff --git a/sorc/ncep_post.fd/PARA_RANGE.f b/sorc/ncep_post.fd/PARA_RANGE.f index f1af1d59d..404e0a41d 100644 --- a/sorc/ncep_post.fd/PARA_RANGE.f +++ b/sorc/ncep_post.fd/PARA_RANGE.f @@ -46,22 +46,4 @@ SUBROUTINE PARA_RANGE (N1,N2,NPROCS,IRANK,ISTA,IEND) if ( iwork2 > irank ) iend = iend + 1 return end - SUBROUTINE PARA_RANGE2 (N1,N2,i1,i2,NPROCS,IRANK,ISTAJ,IENDJ,isx,iex) - - implicit none - integer,intent(in) :: n1,n2,nprocs,irank,i1,i2 - integer,intent(out) :: istaj,iendj,isx,iex - integer iwork1, iwork2 - - iwork1 = ( n2 - n1 + 1 ) / nprocs - iwork2 = mod ( n2 - n1 + 1, nprocs ) - istaj = irank * iwork1 + n1 + min ( irank, iwork2 ) - iendj = istaj + iwork1 - 1 - if ( iwork2 > irank ) iendj = iendj + 1 - isx=i1 - iex=i2 - print 101,' GWVX para_range2 irank,iwork1,iwork2,istaj,iendj,i1,i2,isx,iex',irank,iwork1,iwork2,istaj,iendj,i1,i2,isx,iex - 101 format( a70,11i8) - return - end diff --git a/sorc/ncep_post.fd/PROCESS.f b/sorc/ncep_post.fd/PROCESS.f index 35333fc37..034de6caf 100644 --- a/sorc/ncep_post.fd/PROCESS.f +++ b/sorc/ncep_post.fd/PROCESS.f @@ -51,15 +51,11 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! !---------------------------------------------------------------------------- -<<<<<<< HEAD -! - use IFCORE -======= ! use mpi, only: mpi_wtime ->>>>>>> upstream/develop use CTLBLK_mod, only: cfld, etafld2_tim, eta2p_tim, mdl2sigma_tim, surfce2_tim,& + mdl2agl_tim, mdl2std_tim, mdl2thandpv_tim, calrad_wcloud_tim,& cldrad_tim, miscln_tim, fixed_tim, ntlfld, me !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -74,8 +70,6 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) real(kind=8) :: btim CHARACTER*6 DATSET,PROJ LOGICAL NORTH - integer ifirstt - data ifirstt/0/ ! ! !**************************************************************************** @@ -85,12 +79,7 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! ! COMPUTE/POST FIELDS ON MDL SURFACES. ! -<<<<<<< HEAD -! if(ifirstt .eq. 0 .and. me .eq. 0) call tracebackqq(' GWVX FROM PROCESS',-1) - btim = timef() -======= btim = mpi_wtime() ->>>>>>> upstream/develop CALL MDLFLD ETAFLD2_tim = ETAFLD2_tim +(mpi_wtime() - btim) ! @@ -105,14 +94,10 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) CALL MDL2SIGMA2 MDL2SIGMA_tim = MDL2SIGMA_tim +(mpi_wtime() - btim) ! -<<<<<<< HEAD - CALL MDL2AGL -======= ! COMPUTE/POST FIELDS ON AGL SURFCES. btim = mpi_wtime() CALL MDL2AGL MDL2AGL_tim = MDL2AGL_tim +(mpi_wtime() - btim) ->>>>>>> upstream/develop ! ! COMPUTE/POST SURFACE RELATED FIELDS. btim = mpi_wtime() @@ -136,10 +121,7 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! AND LFM-NGM LOOK-ALIKE FIELDS. btim = mpi_wtime() CALL MDL2STD_P -<<<<<<< HEAD -======= MDL2STD_tim = MDL2STD_tim +(mpi_wtime() - btim) ->>>>>>> upstream/develop ! ! POST FIXED FIELDS. btim = mpi_wtime() @@ -149,26 +131,17 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! COMPUTE/POST FIELDS ON SIGMA SURFACES. btim = mpi_wtime() CALL MDL2THANDPV(kth,kpv,th,pv) -<<<<<<< HEAD -======= MDL2THANDPV_tim = MDL2THANDPV_tim +(mpi_wtime() - btim) ->>>>>>> upstream/develop ! ! POST RADIANCE AND BRIGHTNESS FIELDS. btim = mpi_wtime() CALL CALRAD_WCLOUD -<<<<<<< HEAD -! -======= CALRAD_WCLOUD_tim = CALRAD_WCLOUD_tim +(mpi_wtime() - btim) ! ->>>>>>> upstream/develop ! END OF ROUTINE. ! NTLFLD=cfld if(me==0)print *,'nTLFLD=',NTLFLD - if(me==0)print 101,'GWVX TIMESP ', ETAFLD2_tim , ETA2P_tim , MDL2SIGMA_tim,SURFCE2_tim,CLDRAD_tim, MISCLN_tim,FIXED_tim - 101 format(a30,10f15.2) ! RETURN END diff --git a/sorc/ncep_post.fd/SURFCE.f b/sorc/ncep_post.fd/SURFCE.f index 1225d3c9f..3af081583 100644 --- a/sorc/ncep_post.fd/SURFCE.f +++ b/sorc/ncep_post.fd/SURFCE.f @@ -36,9 +36,8 @@ !! - 20-03-25 J MENG - remove grib1 !! - 20-05-20 J MENG - CALRH unification with NAM scheme !! - 20-11-10 J MENG - USE UPP_PHYSICS MODULE -!! 03/26/20 George Vandenberghe. Added support for 2D -!! decomposition in I as well as J. Changed array allocaton ranges and -!! loop boundaries +!! - 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) +!! - 21-04-01 J MENG - COMPUTATION ON DEFINED POINTS ONLY !! !! USAGE: CALL SURFCE !! INPUT ARGUMENT LIST: @@ -101,7 +100,7 @@ SUBROUTINE SURFCE modelname, tmaxmin, pthresh, dtq2, dt, nphs, & ifhr, prec_acc_dt, sdat, ihrst, jsta_2l, jend_2u,& lp1, imp_physics, me, asrfc, tsrfc, pt, pdtop, & - mpi_comm_comp, im, jm, prec_acc_dt1,ista,iend + mpi_comm_comp, im, jm, prec_acc_dt1 use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml use upp_physics, only: fpvsnew, CALRH !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -124,8 +123,7 @@ SUBROUTINE SURFCE ! ! DECLARE VARIABLES. ! -!gwvx integer, dimension(im,jsta:jend) :: nroots, iwx1 - integer, dimension(ista:iend,jsta:jend) :: nroots, iwx1 + integer, dimension(im,jsta:jend) :: nroots, iwx1 real, allocatable, dimension(:,:) :: zsfc, psfc, tsfc, qsfc, & rhsfc, thsfc, dwpsfc, p1d, & t1d, q1d, zwet, & @@ -133,10 +131,11 @@ SUBROUTINE SURFCE domip, domzr, rsmin, smcref,& rcq, rct, rcsoil, gc, rcs - real, dimension(ista:iend,jsta:jend) :: evp - real, dimension(ista:iend,jsta_2l:jend_2u) :: egrid1, egrid2 - real, dimension(im,jm) :: grid1, grid2 - real, dimension(ista:iend,jsta_2l:jend_2u) :: iceg + real, dimension(im,jsta:jend) :: evp + real, dimension(im,jsta_2l:jend_2u) :: egrid1, egrid2 + real, dimension(im,jsta_2l:jend_2u) :: grid2 + real, dimension(im,jm) :: grid1 + real, dimension(im,jsta_2l:jend_2u) :: iceg ! , ua, va real, allocatable, dimension(:,:,:) :: sleet, rain, freezr, snow ! real, dimension(im,jm,nalg) :: sleet, rain, freezr, snow @@ -152,6 +151,7 @@ SUBROUTINE SURFCE real RDTPHS,TLOW,TSFCK,QSAT,DTOP,DBOT,SNEQV,RRNUM,SFCPRS,SFCQ, & RC,SFCTMP,SNCOVR,FACTRS,SOLAR, s,tk,tl,w,t2c,dlt,APE, & qv,e,dwpt,dum1,dum2,dum3,dum1s,dum3s,dum21,dum216,es + logical, parameter :: debugprint = .false. !**************************************************************************** @@ -170,11 +170,11 @@ SUBROUTINE SURFCE (IGET(154)>0).OR. & (IGET(034)>0).OR.(IGET(076)>0) ) THEN ! - allocate(zsfc(ista:iend,jsta:jend), psfc(ista:iend,jsta:jend), tsfc(ista:iend,jsta:jend)& - ,rhsfc(ista:iend,jsta:jend), thsfc(ista:iend,jsta:jend), qsfc(ista:iend,jsta:jend)) -!$omp parallel do private(i,j,tsfck,qsat) + allocate(zsfc(im,jsta:jend), psfc(im,jsta:jend), tsfc(im,jsta:jend)& + ,rhsfc(im,jsta:jend), thsfc(im,jsta:jend), qsfc(im,jsta:jend)) +!$omp parallel do private(i,j,tsfck,qsat,es) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM ! ! SCALE ARRAY FIS BY GI TO GET SURFACE HEIGHT. ! ZSFC(I,J)=FIS(I,J)*GI @@ -243,7 +243,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = PSFC(i,jj) enddo enddo @@ -259,7 +259,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = ZSFC(i,jj) enddo enddo @@ -276,7 +276,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = TSFC(i,jj) enddo enddo @@ -292,7 +292,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = THSFC(i,jj) enddo enddo @@ -309,7 +309,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = QSFC(i,jj) enddo enddo @@ -327,7 +327,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = DWPSFC(i,jj) enddo enddo @@ -344,7 +344,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = RHSFC(i,jj) enddo enddo @@ -364,7 +364,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = QVG(i,jj) enddo enddo @@ -380,7 +380,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = QV2M(i,jj) enddo enddo @@ -395,7 +395,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = TSNOW(i,jj) enddo enddo @@ -410,7 +410,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = SNFDEN(i,jj) enddo enddo @@ -448,7 +448,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = SNDEPAC(i,jj) enddo enddo @@ -474,7 +474,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = STC(i,jj,l) enddo enddo @@ -494,7 +494,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = STC(i,jj,l) enddo enddo @@ -515,7 +515,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = SMC(i,jj,l) enddo enddo @@ -533,7 +533,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = SMC(i,jj,l) enddo enddo @@ -552,7 +552,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = SH2O(i,jj,l) enddo enddo @@ -570,7 +570,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = SH2O(i,jj,l) enddo enddo @@ -590,7 +590,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = TG(i,jj) enddo enddo @@ -602,7 +602,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = TG(i,jj) enddo enddo @@ -613,7 +613,7 @@ SUBROUTINE SURFCE IF (IGET(171)>0) THEN !!$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(SMSTAV(I,J) /= SPVAL)THEN GRID1(I,J) = SMSTAV(I,J)*100. ELSE @@ -627,7 +627,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -638,7 +638,7 @@ SUBROUTINE SURFCE IF (IGET(036)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM 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 @@ -656,7 +656,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -668,7 +668,7 @@ SUBROUTINE SURFCE IF(MODELNAME == 'RAPR') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(CMC(I,J) /= SPVAL) then GRID1(I,J) = CMC(I,J) else @@ -679,7 +679,7 @@ SUBROUTINE SURFCE else !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(CMC(I,J) /= SPVAL) then GRID1(I,J) = CMC(I,J)*1000. else @@ -694,7 +694,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -710,7 +710,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = SNO(i,jj) enddo enddo @@ -722,7 +722,7 @@ SUBROUTINE SURFCE ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM ! 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) @@ -761,7 +761,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -787,7 +787,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = PSFCAVG(i,jj) enddo enddo @@ -816,7 +816,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = T10AVG(i,jj) enddo enddo @@ -827,7 +827,7 @@ SUBROUTINE SURFCE IF ( IGET(244)>0 ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = SNONC(I,J) ENDDO ENDDO @@ -864,7 +864,7 @@ SUBROUTINE SURFCE IF ( IGET(120)>0 ) THEN GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM ! GRID1(I,J)=PCTSNO(I,J) IF ( SNO(I,J) /= SPVAL ) THEN SNEQV = SNO(I,J) @@ -882,7 +882,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -895,7 +895,7 @@ SUBROUTINE SURFCE ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM 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 @@ -907,7 +907,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -921,7 +921,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = POTEVP(i,jj) enddo enddo @@ -935,7 +935,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = DZICE(i,jj) enddo enddo @@ -961,7 +961,7 @@ SUBROUTINE SURFCE allocate(smcdry(im,jsta:jend), & smcmax(im,jsta:jend)) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM ! ---------------------------------------------------------------------- ! IF(QWBS(I,J)>0.001)print*,'NONZERO QWBS',i,j,QWBS(I,J) ! IF(abs(SM(I,J)-0.)<1.0E-5)THEN @@ -990,7 +990,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = ECAN(i,jj) enddo enddo @@ -1004,7 +1004,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = EDIR(i,jj) enddo enddo @@ -1034,7 +1034,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = SMCDRY(i,jj) enddo enddo @@ -1048,7 +1048,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = SMCMAX(i,jj) enddo enddo @@ -1072,7 +1072,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = acond(i,jj) enddo enddo @@ -1110,7 +1110,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = avgECAN(i,jj) enddo enddo @@ -1148,7 +1148,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = avgEDIR(i,jj) enddo enddo @@ -1238,7 +1238,7 @@ SUBROUTINE SURFCE !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=ista,iend + DO I=1,IM 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) @@ -1253,9 +1253,9 @@ SUBROUTINE SURFCE ! ! SHELTER LEVEL TEMPERATURE IF (IGET(106)>0) THEN -! GRID1=spval + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM ! 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 @@ -1277,7 +1277,7 @@ SUBROUTINE SURFCE IF (IGET(546)>0) THEN ! GRID1=spval ! DO J=JSTA,JEND -! do i=ista,iend +! DO I=1,IM ! GRID1(I,J)=TSHLTR(I,J) ! ENDDO ! ENDDO @@ -1291,7 +1291,7 @@ SUBROUTINE SURFCE ! SHELTER LEVEL SPECIFIC HUMIDITY. IF (IGET(112)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = QSHLTR(I,J) ENDDO ENDDO @@ -1306,7 +1306,7 @@ SUBROUTINE SURFCE ! SHELTER MIXING RATIO. IF (IGET(414)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = MRSHLTR(I,J) ENDDO ENDDO @@ -1322,7 +1322,7 @@ SUBROUTINE SURFCE IF ((IGET(113)>0) .OR.(IGET(547)>0).OR.(IGET(548)>0)) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM !tgs The next 4 lines are GSD algorithm for Dew Point computation !tgs Results are very close to dew point computed in DEWPOINT subroutine @@ -1347,7 +1347,7 @@ SUBROUTINE SURFCE GRID1=spval if(MODELNAME=='RAPR')THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM ! 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) @@ -1355,7 +1355,7 @@ SUBROUTINE SURFCE ENDDO else DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM if(qshltr(i,j)/=spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1372,7 +1372,7 @@ SUBROUTINE SURFCE ! DEWPOINT at level 1 ------ p1d and t1d are undefined !! -- Moorthi IF (IGET(771)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM EVP(I,J)=P1D(I,J)*QVl1(I,J)/(EPS+ONEPS*QVl1(I,J)) EVP(I,J)=EVP(I,J)*D001 ENDDO @@ -1381,7 +1381,7 @@ SUBROUTINE SURFCE ! print *,' MAX DEWPOINT at level 1',maxval(egrid1) GRID1=spval DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM !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 @@ -1396,20 +1396,24 @@ SUBROUTINE SURFCE ! IF ((IGET(547)>0).OR.(IGET(548)>0)) THEN + GRID1=SPVAL + GRID2=SPVAL DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM + 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)) ! SURFACE EQIV POT TEMP in GRID2 APE=(H10E5/PSHLTR(I,J))**CAPA GRID2(I,J)=TSHLTR(I,J)*EXP(ELOCP*QSHLTR(I,J)*APE/TSHLTR(I,J)) + endif ENDDO ENDDO - print *,' MAX/MIN --> DEWPOINT DEPRESSION',maxval(grid1(1:im,jsta:jend)),& - minval(grid1(1:im,jsta:jend)) - print *,' MAX/MIN --> SFC EQUIV POT TEMP',maxval(grid2(1:im,jsta:jend)),& - minval(grid2(1:im,jsta:jend)) +! print *,' MAX/MIN --> DEWPOINT DEPRESSION',maxval(grid1(1:im,jsta:jend)),& +! minval(grid1(1:im,jsta:jend)) +! print *,' MAX/MIN --> SFC EQUIV POT TEMP',maxval(grid2(1:im,jsta:jend)),& +! minval(grid2(1:im,jsta:jend)) IF (IGET(547)>0) THEN if(grib=='grib2') then @@ -1436,7 +1440,7 @@ SUBROUTINE SURFCE allocate(q1d(im,jsta:jend)) !$omp parallel do private(i,j,llmh) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(MODELNAME=='RAPR')THEN LLMH = NINT(LMH(I,J)) ! P1D(I,J)=PINT(I,J,LLMH+1) @@ -1455,7 +1459,7 @@ SUBROUTINE SURFCE if (allocated(q1d)) deallocate(q1d) !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM if(qshltr(i,j) /= spval)then GRID1(I,J) = EGRID1(I,J)*100. else @@ -1471,7 +1475,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1479,9 +1483,11 @@ SUBROUTINE SURFCE ENDIF IF(IGET(808)>0)THEN + GRID2=SPVAL !$omp parallel do private(i,j,dum1,dum2,dum3,dum216,dum1s,dum3s) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM + if(T1D(I,J)/=spval.and.U10H(I,J)/=spval.and.V10H(I,J)0) THEN ! DO J=JSTA,JEND -! do i=ista,iend +! DO I=1,IM ! GRID1(I,J)=PSHLTR(I,J) ! ENDDO ! ENDDO @@ -1544,7 +1551,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = PSHLTR(i,jj) enddo enddo @@ -1556,7 +1563,7 @@ SUBROUTINE SURFCE ! SHELTER LEVEL MAX TEMPERATURE. IF (IGET(345)>0) THEN ! DO J=JSTA,JEND -! do i=ista,iend +! DO I=1,IM ! GRID1(I,J)=MAXTSHLTR(I,J) ! ENDDO ! ENDDO @@ -1593,7 +1600,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = MAXTSHLTR(i,jj) enddo enddo @@ -1604,7 +1611,7 @@ SUBROUTINE SURFCE IF (IGET(346)>0) THEN !!$omp parallel do private(i,j) ! DO J=JSTA,JEND -! do i=ista,iend +! DO I=1,IM ! GRID1(I,J) = MINTSHLTR(I,J) ! ENDDO ! ENDDO @@ -1639,7 +1646,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = MINTSHLTR(i,jj) enddo enddo @@ -1648,9 +1655,10 @@ SUBROUTINE SURFCE ! ! SHELTER LEVEL MAX RH. IF (IGET(347)>0) THEN + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J)=MAXRHSHLTR(I,J)*100. + DO I=1,IM + if(MAXRHSHLTR(I,J)/=spval) GRID1(I,J)=MAXRHSHLTR(I,J)*100. ENDDO ENDDO ID(1:25) = 0 @@ -1685,12 +1693,12 @@ SUBROUTINE SURFCE ! fld_info(cfld)%tinvstat=ITMAXMIN fld_info(cfld)%tinvstat=IFHR-ID(18) if(IFHR==0) fld_info(cfld)%tinvstat=0 - print*,'id(18),tinvstat,IFHR,ITMAXMIN in rhmax= ',ID(18),fld_info(cfld)%tinvstat, & - IFHR, ITMAXMIN +! print*,'id(18),tinvstat,IFHR,ITMAXMIN in rhmax= ',ID(18),fld_info(cfld)%tinvstat, & +! IFHR, ITMAXMIN !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1699,9 +1707,10 @@ SUBROUTINE SURFCE ! ! SHELTER LEVEL MIN RH. IF (IGET(348)>0) THEN + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J)=MINRHSHLTR(I,J)*100. + DO I=1,IM + if(MINRHSHLTR(I,J)/=spval) GRID1(I,J)=MINRHSHLTR(I,J)*100. ENDDO ENDDO ID(1:25) = 0 @@ -1739,7 +1748,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1779,7 +1788,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = maxqshltr(i,jj) enddo enddo @@ -1818,7 +1827,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = minqshltr(i,jj) enddo enddo @@ -1828,8 +1837,10 @@ SUBROUTINE SURFCE ! E. James - 12 Sep 2018: SMOKE from WRF-CHEM on lowest model level ! IF (IGET(739)>0) THEN + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM + 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 ENDDO @@ -1849,7 +1860,7 @@ SUBROUTINE SURFCE IF ((IGET(064)>0).OR.(IGET(065)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = U10(I,J) GRID2(I,J) = V10(I,J) ENDDO @@ -1860,7 +1871,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -1869,7 +1880,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -1879,12 +1890,12 @@ SUBROUTINE SURFCE IF (IGET(730)>0) THEN IFINCR = 5 DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=SPDUV10MEAN(I,J) ENDDO ENDDO if(grib=='grib2') then - print*,'Outputting time-averaged winds' +! print*,'Outputting time-averaged winds' cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(730)) if(fld_info(cfld)%ntrange==0) then @@ -1903,7 +1914,7 @@ SUBROUTINE SURFCE IF (IGET(731)>0) THEN IFINCR = 5 DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=U10MEAN(I,J) ENDDO ENDDO @@ -1925,7 +1936,7 @@ SUBROUTINE SURFCE IF (IGET(732)>0) THEN IFINCR = 5 DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=V10MEAN(I,J) ENDDO ENDDO @@ -1947,7 +1958,7 @@ SUBROUTINE SURFCE IF (IGET(733)>0 )THEN IFINCR = 15 DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = SWRADMEAN(I,J) ENDDO ENDDO @@ -1969,7 +1980,7 @@ SUBROUTINE SURFCE IF (IGET(734)>0 )THEN IFINCR = 15 DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = SWNORMMEAN(I,J) ENDDO ENDDO @@ -1999,7 +2010,7 @@ SUBROUTINE SURFCE ENDIF !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = U10MAX(I,J) GRID2(I,J) = V10MAX(I,J) ENDDO @@ -2012,7 +2023,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2023,7 +2034,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2037,7 +2048,7 @@ SUBROUTINE SURFCE IF (IGET(158)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=TH10(I,J) ENDDO ENDDO @@ -2047,7 +2058,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2059,7 +2070,7 @@ SUBROUTINE SURFCE IF (IGET(505)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=T10M(I,J) ENDDO ENDDO @@ -2069,7 +2080,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2081,7 +2092,7 @@ SUBROUTINE SURFCE IF (IGET(159)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = Q10(I,J) ENDDO ENDDO @@ -2091,7 +2102,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2105,7 +2116,7 @@ SUBROUTINE SURFCE IF (IGET(422)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = WSPD10MAX(I,J) ENDDO ENDDO @@ -2121,7 +2132,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2133,7 +2144,7 @@ SUBROUTINE SURFCE IF (IGET(783)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = WSPD10UMAX(I,J) ENDDO ENDDO @@ -2149,7 +2160,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2161,7 +2172,7 @@ SUBROUTINE SURFCE IF (IGET(784)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = WSPD10VMAX(I,J) ENDDO ENDDO @@ -2177,7 +2188,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2195,7 +2206,7 @@ SUBROUTINE SURFCE CALL CALVESSEL(ICEG(1,jsta)) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = ICEG(I,J) ENDDO ENDDO @@ -2213,7 +2224,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2240,7 +2251,7 @@ SUBROUTINE SURFCE IF (IGET(172)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF (PREC(I,J) <= PTHRESH .OR. SR(I,J)==spval) THEN GRID1(I,J) = -50. ELSE @@ -2254,7 +2265,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2266,10 +2277,11 @@ SUBROUTINE SURFCE IF (IGET(249)>0) THEN RDTPHS=1000./DTQ2 !--- 1000 kg/m**3, density of liquid water ! RDTPHS=1000./(TRDLW*3600.) + GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J) = CPRATE(I,J)*RDTPHS + DO I=1,IM + if(CPRATE(I,J)/=spval) GRID1(I,J) = CPRATE(I,J)*RDTPHS ! GRID1(I,J) = CUPPT(I,J)*RDTPHS ENDDO ENDDO @@ -2279,7 +2291,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2291,14 +2303,17 @@ SUBROUTINE SURFCE !MEB need to get physics DT RDTPHS=1./(DTQ2) !MEB need to get physics DT + GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM + if(PREC(I,J)/=spval) then IF(MODELNAME /= 'RSM') THEN GRID1(I,J) = PREC(I,J)*RDTPHS*1000. ELSE !Add by Binbin GRID1(I,J) = PREC(I,J) END IF + endif ENDDO ENDDO if(grib=='grib2') then @@ -2307,7 +2322,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2317,9 +2332,10 @@ SUBROUTINE SURFCE ! MAXIMUM INSTANTANEOUS PRECIPITATION RATE. IF (IGET(508)>0) THEN !-- PRATE_MAX in units of mm/h from NMMB history files + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J)=PRATE_MAX(I,J)*SEC2HR + DO I=1,IM + if(PRATE_MAX(I,J)/=spval) GRID1(I,J)=PRATE_MAX(I,J)*SEC2HR ENDDO ENDDO if(grib=='grib2') then @@ -2335,7 +2351,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2345,9 +2361,10 @@ SUBROUTINE SURFCE ! MAXIMUM INSTANTANEOUS *FROZEN* PRECIPITATION RATE. IF (IGET(509)>0) THEN !-- FPRATE_MAX in units of mm/h from NMMB history files + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J)=FPRATE_MAX(I,J)*SEC2HR + DO I=1,IM + if(FPRATE_MAX(I,J)/=spval) GRID1(I,J)=FPRATE_MAX(I,J)*SEC2HR ENDDO ENDDO if(grib=='grib2') then @@ -2363,7 +2380,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2397,7 +2414,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM if(AVGCPRATE(I,J)/=spval) GRID1(I,J) = AVGCPRATE(I,J)*RDTPHS ENDDO ENDDO @@ -2419,7 +2436,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2454,7 +2471,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM if(avgprec(i,j)/=spval) GRID1(I,J) = AVGPREC(I,J)*RDTPHS ENDDO ENDDO @@ -2473,7 +2490,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2505,7 +2522,7 @@ SUBROUTINE SURFCE IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(AVGPREC(I,J) < SPVAL)THEN GRID1(I,J) = AVGPREC(I,J)*FLOAT(ID(19)-ID(18))*3600.*1000./DTQ2 ELSE @@ -2515,7 +2532,7 @@ SUBROUTINE SURFCE ENDDO !! Chuang 3/29/2018: add continuous bucket ! DO J=JSTA,JEND -! do i=ista,iend +! DO I=1,IM ! IF(AVGPREC_CONT(I,J) < SPVAL)THEN ! GRID2(I,J) = AVGPREC_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ! ELSE @@ -2526,8 +2543,12 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM + IF(ACPREC(I,J) < SPVAL)THEN GRID1(I,J) = ACPREC(I,J)*1000. + ELSE + GRID1(I,J) = SPVAL + ENDIF ENDDO ENDDO END IF @@ -2547,7 +2568,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2560,7 +2581,7 @@ SUBROUTINE SURFCE ! print*,'tinvstat in cont bucket= ',fld_info(cfld)%tinvstat ! do j=1,jend-jsta+1 ! jj = jsta+j-1 -! do i=ista,iend +! do i=1,im ! datapd(i,j,cfld) = GRID2(i,jj) ! enddo ! enddo @@ -2595,7 +2616,7 @@ SUBROUTINE SURFCE ! Chuang 3/29/2018: add continuous bucket !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(AVGPREC_CONT(I,J) < SPVAL)THEN GRID2(I,J) = AVGPREC_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ELSE @@ -2616,7 +2637,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2650,7 +2671,7 @@ SUBROUTINE SURFCE IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(AVGCPRATE(I,J) < SPVAL)THEN GRID1(I,J) = AVGCPRATE(I,J)* & FLOAT(ID(19)-ID(18))*3600.*1000./DTQ2 @@ -2661,7 +2682,7 @@ SUBROUTINE SURFCE ENDDO !! Chuang 3/29/2018: add continuous bucket ! DO J=JSTA,JEND -! do i=ista,iend +! DO I=1,IM ! IF(AVGCPRATE_CONT(I,J) < SPVAL)THEN ! GRID2(I,J) = AVGCPRATE_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ! ELSE @@ -2672,8 +2693,12 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM + IF(CUPREC(I,J) < SPVAL)THEN GRID1(I,J) = CUPREC(I,J)*1000. + ELSE + GRID1(I,J) = SPVAL + ENDIF ENDDO ENDDO END IF @@ -2686,7 +2711,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2698,7 +2723,7 @@ SUBROUTINE SURFCE ! fld_info(cfld)%tinvstat=IFHR ! do j=1,jend-jsta+1 ! jj = jsta+j-1 -! do i=ista,iend +! do i=1,im ! datapd(i,j,cfld) = GRID2(i,jj) ! enddo ! enddo @@ -2733,7 +2758,7 @@ SUBROUTINE SURFCE ! Chuang 3/29/2018: add continuous bucket !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(AVGCPRATE_CONT(I,J) < SPVAL)THEN GRID2(I,J) = AVGCPRATE_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ELSE @@ -2753,7 +2778,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2788,7 +2813,7 @@ SUBROUTINE SURFCE IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM 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 @@ -2799,7 +2824,7 @@ SUBROUTINE SURFCE ENDDO !! Chuang 3/29/2018: add continuous bucket ! DO J=JSTA,JEND -! do i=ista,iend +! DO I=1,IM ! 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 @@ -2811,7 +2836,7 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = ANCPRC(I,J)*1000. ENDDO ENDDO @@ -2825,7 +2850,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2837,7 +2862,7 @@ SUBROUTINE SURFCE ! fld_info(cfld)%tinvstat=IFHR ! do j=1,jend-jsta+1 ! jj = jsta+j-1 -! do i=ista,iend +! do i=1,im ! datapd(i,j,cfld) = GRID2(i,jj) ! enddo ! enddo @@ -2872,7 +2897,7 @@ SUBROUTINE SURFCE ! Chuang 3/29/2018: add continuous bucket !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM 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 @@ -2893,7 +2918,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID2(i,jj) enddo enddo @@ -2903,13 +2928,14 @@ SUBROUTINE SURFCE ! ! ACCUMULATED LAND SURFACE PRECIPITATION. IF (IGET(256)>0) THEN + GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(LSPA(I,J)<=-1.0E-6)THEN - GRID1(I,J) = ACPREC(I,J)*1000 + if(ACPREC(I,J)/=spval) GRID1(I,J) = ACPREC(I,J)*1000 ELSE - GRID1(I,J) = LSPA(I,J)*1000. + if(LSPA(I,J)/=spval) GRID1(I,J) = LSPA(I,J)*1000. END IF ENDDO ENDDO @@ -2943,7 +2969,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2954,7 +2980,7 @@ SUBROUTINE SURFCE IF (IGET(035)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM ! GRID1(I,J) = ACSNOW(I,J)*1000. GRID1(I,J) = ACSNOW(I,J) ENDDO @@ -2988,7 +3014,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2999,7 +3025,7 @@ SUBROUTINE SURFCE IF (IGET(746)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = ACGRAUP(I,J) ENDDO ENDDO @@ -3032,7 +3058,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3043,7 +3069,7 @@ SUBROUTINE SURFCE IF (IGET(782)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = ACFRAIN(I,J) ENDDO ENDDO @@ -3076,7 +3102,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3087,7 +3113,7 @@ SUBROUTINE SURFCE IF (IGET(121)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM ! GRID1(I,J) = ACSNOM(I,J)*1000. GRID1(I,J) = ACSNOM(I,J) ENDDO @@ -3121,7 +3147,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3132,7 +3158,7 @@ SUBROUTINE SURFCE IF (IGET(405)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = SNOWFALL(I,J) ENDDO ENDDO @@ -3166,7 +3192,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3177,7 +3203,7 @@ SUBROUTINE SURFCE IF (IGET(122)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM ! GRID1(I,J) = SSROFF(I,J)*1000. GRID1(I,J) = SSROFF(I,J) ENDDO @@ -3219,7 +3245,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3230,7 +3256,7 @@ SUBROUTINE SURFCE IF (IGET(123)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM ! GRID1(I,J) = BGROFF(I,J)*1000. GRID1(I,J) = BGROFF(I,J) ENDDO @@ -3272,7 +3298,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3283,7 +3309,7 @@ SUBROUTINE SURFCE IF (IGET(343)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = RUNOFF(I,J) ENDDO ENDDO @@ -3319,7 +3345,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3331,7 +3357,7 @@ SUBROUTINE SURFCE IF (IGET(434)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF (IFHR == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3381,7 +3407,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3393,7 +3419,7 @@ SUBROUTINE SURFCE IF (IGET(435)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF (IFHR == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3426,7 +3452,9 @@ SUBROUTINE SURFCE IF (ID(18)<0) ID(18) = 0 ! print *,'IFMIN,IFHR,ITPREC',IFMIN,IFHR,ITPREC - if(me==0)print *,'PREC_ACC_DT,ID(18),ID(19)',PREC_ACC_DT,ID(18),ID(19) + if(debugprint .and. me==0)then + print *,'PREC_ACC_DT,ID(18),ID(19)',PREC_ACC_DT,ID(18),ID(19) + endif if(grib=='grib2') then cfld=cfld+1 @@ -3448,7 +3476,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3459,7 +3487,7 @@ SUBROUTINE SURFCE IF (IGET(436)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF (IFHR == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3509,7 +3537,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3520,7 +3548,7 @@ SUBROUTINE SURFCE IF (IGET(437)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = SNOW_BUCKET(I,J) ENDDO ENDDO @@ -3546,7 +3574,7 @@ SUBROUTINE SURFCE IF(IFMIN >= 1)ID(18)=IFHR*60+IFMIN-IFINCR ENDIF IF (ID(18)<0) ID(18) = 0 - if(me==0)print*,'maxval BUCKET SNOWFALL: ', maxval(GRID1) +! if(me==0)print*,'maxval BUCKET SNOWFALL: ', maxval(GRID1) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(437)) @@ -3567,7 +3595,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3578,7 +3606,7 @@ SUBROUTINE SURFCE IF (IGET(775)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = GRAUP_BUCKET(I,J) ENDDO ENDDO @@ -3604,7 +3632,7 @@ SUBROUTINE SURFCE IF(IFMIN >= 1)ID(18)=IFHR*60+IFMIN-IFINCR ENDIF IF (ID(18)<0) ID(18) = 0 - print*,'maxval BUCKET GRAUPEL: ', maxval(GRID1) +! print*,'maxval BUCKET GRAUPEL: ', maxval(GRID1) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(775)) @@ -3625,7 +3653,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3638,7 +3666,7 @@ SUBROUTINE SURFCE IF (IGET(526)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3661,7 +3689,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3671,7 +3699,7 @@ SUBROUTINE SURFCE IF (IGET(527)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3694,7 +3722,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3704,7 +3732,7 @@ SUBROUTINE SURFCE IF (IGET(528)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3727,7 +3755,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3737,7 +3765,7 @@ SUBROUTINE SURFCE IF (IGET(529)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3746,7 +3774,7 @@ SUBROUTINE SURFCE ENDDO ENDDO IFINCR = NINT(PREC_ACC_DT1) - if(me==0)print*,'maxval BUCKET1 SNOWFALL: ', maxval(GRID1) +! if(me==0)print*,'maxval BUCKET1 SNOWFALL: ', maxval(GRID1) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(521)) @@ -3761,7 +3789,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3771,7 +3799,7 @@ SUBROUTINE SURFCE IF (IGET(530)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3780,7 +3808,7 @@ SUBROUTINE SURFCE ENDDO ENDDO IFINCR = NINT(PREC_ACC_DT1) - print*,'maxval BUCKET1 GRAUPEL: ', maxval(GRID1) +! print*,'maxval BUCKET1 GRAUPEL: ', maxval(GRID1) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(522)) @@ -3795,7 +3823,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3816,7 +3844,7 @@ SUBROUTINE SURFCE IF (IGET(160)>0) THEN !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IWX = IWX1(I,J) SNOW(I,J,1) = MOD(IWX,2) SLEET(I,J,1) = MOD(IWX,4)/2 @@ -3829,7 +3857,7 @@ SUBROUTINE SURFCE ! LOWEST WET BULB ZERO HEIGHT IF (IGET(247)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = ZWET(I,J) ENDDO ENDDO @@ -3839,7 +3867,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3860,7 +3888,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IWX = IWX1(I,J) SNOW(I,J,2) = MOD(IWX,2) SLEET(I,J,2) = MOD(IWX,4)/2 @@ -3883,7 +3911,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IWX = IWX1(I,J) SNOW(I,J,3) = MOD(IWX,2) SLEET(I,J,3) = MOD(IWX,4)/2 @@ -3899,7 +3927,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IWX = IWX1(I,J) SNOW(I,J,4) = MOD(IWX,2) SLEET(I,J,4) = MOD(IWX,4)/2 @@ -3915,7 +3943,7 @@ SUBROUTINE SURFCE else !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IWX1(I,J) = 0 ENDDO ENDDO @@ -3925,7 +3953,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IWX = IWX1(I,J) SNOW(I,J,5) = MOD(IWX,2) SLEET(I,J,5) = MOD(IWX,4)/2 @@ -3943,7 +3971,7 @@ SUBROUTINE SURFCE grid1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM if(prec(i,j) /= spval) GRID1(I,J) = DOMS(I,J) ENDDO ENDDO @@ -3953,7 +3981,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3962,7 +3990,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM if(prec(i,j)/=spval) GRID1(I,J) = DOMIP(I,J) ENDDO ENDDO @@ -3972,7 +4000,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -3981,7 +4009,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM ! if (DOMZR(I,J) == 1) THEN ! PSFC(I,J)=PINT(I,J,NINT(LMH(I,J))+1) ! print *, 'aha ', I, J, PSFC(I,J) @@ -3997,7 +4025,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4006,7 +4034,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM if(prec(i,j)/=spval)GRID1(I,J) = DOMR(I,J) ENDDO ENDDO @@ -4016,7 +4044,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4039,7 +4067,7 @@ SUBROUTINE SURFCE ! print *,'in SURFCE,me=',me,'IWX1=',IWX1(1:30,JSTA) !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IWX = IWX1(I,J) SNOW(I,J,1) = MOD(IWX,2) SLEET(I,J,1) = MOD(IWX,4)/2 @@ -4061,7 +4089,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IWX = IWX1(I,J) SNOW(I,J,2) = MOD(IWX,2) SLEET(I,J,2) = MOD(IWX,4)/2 @@ -4084,7 +4112,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IWX = IWX1(I,J) SNOW(I,J,3) = MOD(IWX,2) SLEET(I,J,3) = MOD(IWX,4)/2 @@ -4101,7 +4129,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IWX = IWX1(I,J) SNOW(I,J,4) = MOD(IWX,2) SLEET(I,J,4) = MOD(IWX,4)/2 @@ -4118,7 +4146,7 @@ SUBROUTINE SURFCE else !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IWX1(I,J) = 0 ENDDO ENDDO @@ -4128,7 +4156,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IWX = IWX1(I,J) SNOW(I,J,5) = MOD(IWX,2) SLEET(I,J,5) = MOD(IWX,4)/2 @@ -4178,7 +4206,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM if(avgprec(i,j) /= spval) GRID1(I,J) = DOMS(I,J) ENDDO ENDDO @@ -4196,7 +4224,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4225,7 +4253,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM if(avgprec(i,j)/=spval) GRID1(I,J) = DOMIP(I,J) ENDDO ENDDO @@ -4242,7 +4270,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4272,7 +4300,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM ! if (DOMZR(I,J) == 1) THEN ! PSFC(I,J)=PINT(I,J,NINT(LMH(I,J))+1) ! print *, 'aha ', I, J, PSFC(I,J) @@ -4295,7 +4323,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4326,7 +4354,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM if(avgprec(i,j)/=spval) GRID1(I,J) = DOMR(I,J) ENDDO ENDDO @@ -4343,7 +4371,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4367,7 +4395,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM DOMS(I,J) = 0. !-- snow DOMR(I,J) = 0. !-- rain DOMZR(I,J) = 0. !-- freezing rain @@ -4376,7 +4404,7 @@ SUBROUTINE SURFCE ENDDO DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM !-- TOTPRCP is total 1-hour accumulated precipitation in [m] totprcp = (RAINC_BUCKET(I,J) + RAINNC_BUCKET(I,J))*1.e-3 snowratio = 0.0 @@ -4497,7 +4525,7 @@ SUBROUTINE SURFCE maxval(snow_bucket)*0.1,minval(snow_bucket)*0.1 DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM 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 @@ -4514,7 +4542,7 @@ SUBROUTINE SURFCE icnt_snow_rain_mixed = 0 DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM if (DOMR(i,j)==1 .and. DOMS(i,j)==1) then icnt_snow_rain_mixed = icnt_snow_rain_mixed + 1 endif @@ -4528,7 +4556,7 @@ SUBROUTINE SURFCE ! SNOW. !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=DOMS(I,J) ENDDO ENDDO @@ -4538,7 +4566,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4546,7 +4574,7 @@ SUBROUTINE SURFCE ! ICE PELLETS. !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = DOMIP(I,J) ! if (DOMIP(I,J) == 1) THEN ! print *, 'ICE PELLETS at I,J ', I, J @@ -4559,7 +4587,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4567,7 +4595,7 @@ SUBROUTINE SURFCE ! FREEZING RAIN. !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM ! 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) @@ -4581,7 +4609,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4589,7 +4617,7 @@ SUBROUTINE SURFCE ! RAIN. !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = DOMR(I,J) ENDDO ENDDO @@ -4599,7 +4627,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -4629,7 +4657,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(SFCLHX(I,J)/=SPVAL)THEN GRID1(I,J)=-1.*SFCLHX(I,J)*RRNUM !change the sign to conform with Grib ELSE @@ -4682,7 +4710,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(SFCSHX(I,J)/=SPVAL)THEN GRID1(I,J) = -1.* SFCSHX(I,J)*RRNUM !change the sign to conform with Grib ELSE @@ -4734,9 +4762,10 @@ SUBROUTINE SURFCE ELSE RRNUM=0. ENDIF + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J) = SUBSHX(I,J)*RRNUM + DO I=1,IM + if(SUBSHX(I,J)/=spval) GRID1(I,J) = SUBSHX(I,J)*RRNUM ENDDO ENDDO ID(1:25) = 0 @@ -4783,9 +4812,10 @@ SUBROUTINE SURFCE ELSE RRNUM=0. ENDIF + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J) = SNOPCX(I,J)*RRNUM + DO I=1,IM + if(SNOPCX(I,J)/=spval) GRID1(I,J) = SNOPCX(I,J)*RRNUM ENDDO ENDDO ID(1:25) = 0 @@ -4833,7 +4863,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(SFCUVX(I,J)/=SPVAL)THEN GRID1(I,J) = SFCUVX(I,J)*RRNUM ELSE @@ -4885,9 +4915,10 @@ SUBROUTINE SURFCE ELSE RRNUM=0. ENDIF + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J) = SFCUX(I,J)*RRNUM + DO I=1,IM + if(SFCUX(I,J)/=spval) GRID1(I,J) = SFCUX(I,J)*RRNUM ENDDO ENDDO ID(1:25) = 0 @@ -4934,9 +4965,10 @@ SUBROUTINE SURFCE ELSE RRNUM=0. ENDIF + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J) = SFCVX(I,J)*RRNUM + DO I=1,IM + if(SFCVX(I,J)/=spval) GRID1(I,J) = SFCVX(I,J)*RRNUM ENDDO ENDDO ID(1:25) = 0 @@ -4973,9 +5005,10 @@ SUBROUTINE SURFCE ! ! ACCUMULATED SURFACE EVAPORATION IF (IGET(047)>0) THEN + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J) = SFCEVP(I,J)*1000. + DO I=1,IM + if(SFCEVP(I,J)/=spval) GRID1(I,J) = SFCEVP(I,J)*1000. ENDDO ENDDO ID(1:25) = 0 @@ -5015,9 +5048,10 @@ SUBROUTINE SURFCE ! ! ACCUMULATED POTENTIAL EVAPORATION IF (IGET(137)>0) THEN + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J) = POTEVP(I,J)*1000. + DO I=1,IM + if(POTEVP(I,J)/=spval) GRID1(I,J) = POTEVP(I,J)*1000. ENDDO ENDDO ID(1:25) = 0 @@ -5057,7 +5091,7 @@ SUBROUTINE SURFCE ! ROUGHNESS LENGTH. IF (IGET(044)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = Z0(I,J) ENDDO ENDDO @@ -5071,7 +5105,7 @@ SUBROUTINE SURFCE ! FRICTION VELOCITY. IF (IGET(045)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = USTAR(I,J) ENDDO ENDDO @@ -5088,7 +5122,7 @@ SUBROUTINE SURFCE GRID1=spval CALL CALDRG(EGRID1(1,jsta_2l)) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(USTAR(I,J) < spval) GRID1(I,J)=EGRID1(I,J) ENDDO ENDDO @@ -5101,7 +5135,7 @@ SUBROUTINE SURFCE write_cd: IF(IGET(922)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=CD10(I,J) ENDDO ENDDO @@ -5113,7 +5147,7 @@ SUBROUTINE SURFCE ENDIF write_cd write_ch: IF(IGET(923)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=CH10(I,J) ENDDO ENDDO @@ -5130,7 +5164,7 @@ SUBROUTINE SURFCE ! MODEL OUTPUT SURFACE U COMPONENT WIND STRESS. IF (IGET(900)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=MDLTAUX(I,J) ENDDO ENDDO @@ -5145,7 +5179,7 @@ SUBROUTINE SURFCE ! MODEL OUTPUT SURFACE V COMPONENT WIND STRESS IF (IGET(901)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=MDLTAUY(I,J) ENDDO ENDDO @@ -5167,7 +5201,7 @@ SUBROUTINE SURFCE ! dong for FV3, directly use model output IF (IGET(133)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=EGRID1(I,J) IF(MODELNAME == 'FV3R') THEN GRID1(I,J)=SFCUXI(I,J) @@ -5185,7 +5219,7 @@ SUBROUTINE SURFCE ! SURFACE V COMPONENT WIND STRESS IF (IGET(134)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=EGRID2(I,J) IF(MODELNAME == 'FV3R') THEN GRID1(I,J)=SFCVXI(I,J) @@ -5206,7 +5240,7 @@ SUBROUTINE SURFCE ! GRAVITY U COMPONENT WIND STRESS. IF (IGET(315)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = GTAUX(I,J) ENDDO ENDDO @@ -5244,7 +5278,7 @@ SUBROUTINE SURFCE ! SURFACE V COMPONENT WIND STRESS IF (IGET(316)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=GTAUY(I,J) ENDDO ENDDO @@ -5288,14 +5322,14 @@ SUBROUTINE SURFCE MODELNAME=='RAPR')THEN !4omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = TWBS(I,J) ENDDO ENDDO ELSE !4omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(TWBS(I,J) < spval) GRID1(I,J) = -TWBS(I,J) ENDDO ENDDO @@ -5315,14 +5349,14 @@ SUBROUTINE SURFCE MODELNAME=='RAPR')THEN !4omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = QWBS(I,J) ENDDO ENDDO ELSE !4omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF(QWBS(I,J) < spval) GRID1(I,J) = -QWBS(I,J) ENDDO ENDDO @@ -5337,7 +5371,7 @@ SUBROUTINE SURFCE ! SURFACE EXCHANGE COEFF IF (IGET(169)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=SFCEXC(I,J) ENDDO ENDDO @@ -5350,9 +5384,10 @@ SUBROUTINE SURFCE ! ! GREEN VEG FRACTION IF (IGET(170)>0) THEN + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J)=VEGFRC(I,J)*100. + DO I=1,IM + if(VEGFRC(I,J)/=spval) GRID1(I,J)=VEGFRC(I,J)*100. ENDDO ENDDO if(grib=='grib2') then @@ -5365,9 +5400,10 @@ SUBROUTINE SURFCE ! ! MIN GREEN VEG FRACTION IF (IGET(726)>0) THEN + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J)=shdmin(I,J)*100. + DO I=1,IM + if(shdmin(I,J)/=spval) GRID1(I,J)=shdmin(I,J)*100. ENDDO ENDDO if(grib=='grib2') then @@ -5379,9 +5415,10 @@ SUBROUTINE SURFCE ! ! MAX GREEN VEG FRACTION IF (IGET(729)>0) THEN + GRID1=SPVAL DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J)=shdmax(I,J)*100. + DO I=1,IM + if(shdmax(I,J)/=spval) GRID1(I,J)=shdmax(I,J)*100. ENDDO ENDDO if(grib=='grib2') then @@ -5397,7 +5434,7 @@ SUBROUTINE SURFCE IF (iSF_SURFACE_PHYSICS == 2 .OR. MODELNAME=='RAPR') THEN IF (IGET(254)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM IF (MODELNAME=='RAPR')THEN GRID1(I,J)=LAI(I,J) ELSE @@ -5417,7 +5454,7 @@ SUBROUTINE SURFCE ! INSTANTANEOUS GROUND HEAT FLUX IF (IGET(152)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=GRNFLX(I,J) ENDDO ENDDO @@ -5430,7 +5467,7 @@ SUBROUTINE SURFCE ! VEGETATION TYPE IF (IGET(218)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = FLOAT(IVGTYP(I,J)) ENDDO ENDDO @@ -5444,7 +5481,7 @@ SUBROUTINE SURFCE ! SOIL TYPE IF (IGET(219)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = FLOAT(ISLTYP(I,J)) ENDDO ENDDO @@ -5457,7 +5494,7 @@ SUBROUTINE SURFCE ! SLOPE TYPE IF (IGET(223)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = FLOAT(ISLOPE(I,J)) ENDDO ENDDO @@ -5467,7 +5504,7 @@ SUBROUTINE SURFCE datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) endif ENDIF - if (me==0)print*,'starting computing canopy conductance' +! if (me==0)print*,'starting computing canopy conductance' ! ! CANOPY CONDUCTANCE ! ONLY OUTPUT NEW LSM FIELDS FOR NMM AND ARW BECAUSE RSM USES OLD SOIL TYPES @@ -5479,11 +5516,11 @@ SUBROUTINE SURFCE & .OR. IGET(239)>0 .OR. IGET(240)>0 & & .OR. IGET(241)>0 ) THEN IF (iSF_SURFACE_PHYSICS == 2) THEN !NSOIL == 4 - if(me==0)print*,'starting computing canopy conductance' +! 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)) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM 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 @@ -5526,7 +5563,7 @@ SUBROUTINE SURFCE IF (IGET(220)>0 )THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = GC(I,J) ENDDO ENDDO @@ -5539,7 +5576,7 @@ SUBROUTINE SURFCE IF (IGET(234)>0 )THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = RSMIN(I,J) ENDDO ENDDO @@ -5552,7 +5589,7 @@ SUBROUTINE SURFCE IF (IGET(235)>0 )THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = FLOAT(NROOTS(I,J)) ENDDO ENDDO @@ -5565,7 +5602,7 @@ SUBROUTINE SURFCE IF (IGET(236)>0 )THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = SMCWLT(I,J) ENDDO ENDDO @@ -5578,7 +5615,7 @@ SUBROUTINE SURFCE IF (IGET(237)>0 )THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = SMCREF(I,J) ENDDO ENDDO @@ -5591,7 +5628,7 @@ SUBROUTINE SURFCE IF (IGET(238)>0 )THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = RCS(I,J) ENDDO ENDDO @@ -5604,7 +5641,7 @@ SUBROUTINE SURFCE IF (IGET(239)>0 )THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = RCT(I,J) ENDDO ENDDO @@ -5617,7 +5654,7 @@ SUBROUTINE SURFCE IF (IGET(240)>0 )THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = RCQ(I,J) ENDDO ENDDO @@ -5630,7 +5667,7 @@ SUBROUTINE SURFCE IF (IGET(241)>0 )THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = RCSOIL(I,J) ENDDO ENDDO @@ -5659,7 +5696,7 @@ SUBROUTINE SURFCE IF(IGET(236)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = smcwlt(i,j) ! IF(isltyp(i,j)/=0)THEN ! GRID1(I,J) = WLTSMC(isltyp(i,j)) @@ -5674,7 +5711,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5684,7 +5721,7 @@ SUBROUTINE SURFCE IF(IGET(397)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = fieldcapa(i,j) ! IF(isltyp(i,j)/=0)THEN ! GRID1(I,J) = REFSMC(isltyp(i,j)) @@ -5699,7 +5736,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5709,7 +5746,7 @@ SUBROUTINE SURFCE IF(IGET(396)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = suntime(i,j) ENDDO ENDDO @@ -5743,7 +5780,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5753,7 +5790,7 @@ SUBROUTINE SURFCE IF(IGET(517)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = avgpotevp(i,j) ENDDO ENDDO @@ -5787,7 +5824,7 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=ista,iend + do i=1,im datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -5800,7 +5837,7 @@ SUBROUTINE SURFCE IF (IGET(282)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J) = PT ENDDO ENDDO @@ -5814,7 +5851,7 @@ SUBROUTINE SURFCE ! PRESSURE THICKNESS REQUESTED BY CMAQ IF (IGET(283)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=PDTOP ENDDO ENDDO @@ -5823,7 +5860,7 @@ SUBROUTINE SURFCE DO L=1,LM IF(PMID(1,1,L)>=(PDTOP+PT))EXIT END DO - PRINT*,'hybrid boundary ',L +! PRINT*,'hybrid boundary ',L END IF CALL MPI_BCAST(L,1,MPI_INTEGER,0,mpi_comm_comp,irtn) if(grib=='grib2') then @@ -5838,7 +5875,7 @@ SUBROUTINE SURFCE ! SIGMA PRESSURE THICKNESS REQUESTED BY CMAQ IF (IGET(273)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=PD(I,J) ENDDO ENDDO @@ -5847,7 +5884,7 @@ SUBROUTINE SURFCE ! print*,'Debug CMAQ: ',L,PINT(1,1,LM+1),PD(1,1),PINT(1,1,L) IF((PINT(1,1,LM+1)-PD(1,1))<=(PINT(1,1,L)+1.00))EXIT END DO - PRINT*,'hybrid boundary ',L +! PRINT*,'hybrid boundary ',L END IF CALL MPI_BCAST(L,1,MPI_INTEGER,0,mpi_comm_comp,irtn) if(grib=='grib2') then @@ -5863,7 +5900,7 @@ SUBROUTINE SURFCE ! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR MASS REQUESTED FOR CMAQ IF (IGET(503)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=AKHSAVG(I,J) ENDDO ENDDO @@ -5888,7 +5925,7 @@ SUBROUTINE SURFCE ! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR WIND REQUESTED FOR CMAQ IF (IGET(504)>0) THEN DO J=JSTA,JEND - do i=ista,iend + DO I=1,IM GRID1(I,J)=AKMSAVG(I,J) ENDDO ENDDO @@ -5910,57 +5947,6 @@ SUBROUTINE SURFCE endif ENDIF - - -! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR MASS REQUESTED FOR CMAQ - IF (IGET(503)>0) THEN - DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J)=AKHSAVG(I,J) - ENDDO - ENDDO - ID(1:25) = 0 - ID(02)= 133 - ID(19) = IFHR - IF (IFHR==0) THEN - ID(18) = 0 - ELSE - ID(18) = IFHR - 1 - ENDIF - ID(20) = 3 - if(grib=='grib2') then - cfld=cfld+1 - 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) - endif - ENDIF - -! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR WIND REQUESTED FOR CMAQ - IF (IGET(504)>0) THEN - DO J=JSTA,JEND - do i=ista,iend - GRID1(I,J)=AKMSAVG(I,J) - ENDDO - ENDDO - ID(1:25) = 0 - ID(02)= 133 - ID(19) = IFHR - IF (IFHR==0) THEN - ID(18) = 0 - ELSE - ID(18) = IFHR - 1 - ENDIF - ID(20) = 3 - if(grib=='grib2') then - cfld=cfld+1 - 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) - endif - ENDIF RETURN END diff --git a/sorc/ncep_post.fd/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f index a1c2f8bc3..127118e3d 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -143,7 +143,8 @@ PROGRAM WRFPOST lp1, lm1, im_jm, isf_surface_physics, nsoil, spl, lsmp1, global, & 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, & - fixed_tim, time_output, imin, surfce2_tim, komax, ivegsrc, d3d_on, gocart_on, & + 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 use grib2_module, only: gribit2,num_pset,nrecout,first_grbtbl,grib_info_finalize use sigio_module, only: sigio_head @@ -162,7 +163,7 @@ PROGRAM WRFPOST ! !temporary vars ! - real(kind=8) :: time_initpost=0.,INITPOST_tim=0.,btim,timef + real(kind=8) :: time_initpost=0.,INITPOST_tim=0.,btim,bbtim real rinc(5), untcnvt integer :: status=0,iostatusD3D=0,iostatusFlux=0 integer i,j,iii,l,k,ierr,nrec,ist,lusig,idrt,ncid3d,varid @@ -174,11 +175,10 @@ 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 + ,hyb_sigp,rdaod character startdate*19,SysDepInfo*80,IOWRFNAME*3,post_fname*255 character cgar*1,cdum*4,line*10 - real(kind=8) t1,t2,ta,tb,tc,td,te,tf,tg ! !------------------------------------------------------------------------------ ! START HERE @@ -211,7 +211,6 @@ PROGRAM WRFPOST if ( me >= num_procs ) then ! call server - ! else spval = 9.9e10 @@ -246,10 +245,13 @@ PROGRAM WRFPOST ! if (me==0) print*,'VALID TIME UNITS = ', VTIMEUNITS ! endif ! + 303 format('FULLMODELNAME="',A,'" MODELNAME="',A,'" & + SUBMODELNAME="',A,'"') write(0,*)'FULLMODELNAME: ', FULLMODELNAME ! MODELNAME, SUBMODELNAME + if (me==0) print 303,FULLMODELNAME,MODELNAME,SUBMODELNAME ! assume for now that the first date in the stdin file is the start date read(DateStr,300) iyear,imn,iday,ihrst,imin if (me==0) write(*,*) 'in WRFPOST iyear,imn,iday,ihrst,imin', & @@ -269,11 +271,11 @@ PROGRAM WRFPOST 120 format(a5) 121 format(a4) - if (me==0) print*,' MODELNAME= ',MODELNAME,'grib=',grib + if (me==0) print*,'MODELNAME= ',MODELNAME,'grib=',grib !Chuang: If model is GFS, read in flux file name from unit5 if(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') then read(5,111,end=117) fileNameFlux - if (me == 0) print*,' first two file names in GFS or FV3= ' & + if (me == 0) print*,'first two file names in GFS or FV3= ' & ,trim(fileName),trim(fileNameFlux) 117 continue @@ -306,6 +308,7 @@ PROGRAM WRFPOST gocart_on = .false. popascal = .false. fileNameAER = '' + rdaod = .false. ! gocart_on = .true. ! d3d_on = .true. @@ -436,6 +439,7 @@ PROGRAM WRFPOST call ext_ncd_ioclose ( DataHandle, Status ) ELSE ! use netcdf lib directly to read FV3 output in netCDF + spval = 9.99e20 Status = nf90_open(trim(fileName),NF90_NOWRITE, ncid3d) if ( Status /= 0 ) then print*,'error opening ',fileName, ' Status = ', Status @@ -483,6 +487,7 @@ PROGRAM WRFPOST END IF ! use netcdf_parallel lib directly to read FV3 output in netCDF ELSE IF(TRIM(IOFORM) == 'netcdfpara') THEN + spval = 9.99e20 Status = nf90_open(trim(fileName),ior(nf90_nowrite, nf90_mpiio), & ncid3d, comm=mpi_comm_world, info=mpi_info_null) if ( Status /= 0 ) then @@ -730,8 +735,8 @@ PROGRAM WRFPOST CALL MPI_FIRST() - print*,'jsta,jend,jsta_m,jend_m,jsta_2l,jend_2u=',jsta, & - jend,jsta_m,jend_m, jsta_2l,jend_2u + print*,'jsta,jend,jsta_m,jend_m,jsta_2l,jend_2u,spval=',jsta, & + jend,jsta_m,jend_m, jsta_2l,jend_2u,spval CALL ALLOCATE_ALL() ! @@ -741,7 +746,8 @@ PROGRAM WRFPOST REWIND(LCNTRL) ! EXP. initialize netcdf here instead - btim = timef() + bbtim = mpi_wtime() + btim = mpi_wtime() ! set default novegtype if(MODELNAME == 'GFS')THEN novegtype = 13 @@ -761,19 +767,17 @@ PROGRAM WRFPOST IF(TRIM(IOFORM) == 'netcdf') THEN IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR') THEN - print*,' CALLING INITPOST TO PROCESS NCAR NETCDF OUTPUT' + print*,'CALLING INITPOST TO PROCESS NCAR NETCDF OUTPUT' CALL INITPOST ELSE IF(MODELNAME == 'NMM') THEN - print*,' CALLING INITPOST_NMM TO PROCESS NMM NETCDF OUTPUT' + print*,'CALLING INITPOST_NMM TO PROCESS NMM NETCDF OUTPUT' CALL INITPOST_NMM ELSE IF (MODELNAME == 'FV3R') THEN ! use netcdf library to read output directly - spval = 9.99e20 - if(me .eq. 0) print*,' CALLING INITPOST_NETCDF' + print*,'CALLING INITPOST_NETCDF' CALL INITPOST_NETCDF(ncid3d) ELSE IF (MODELNAME == 'GFS') THEN - spval = 9.99e20 - print*,' CALLING INITPOST_GFS_NETCDF' + print*,'CALLING INITPOST_GFS_NETCDF' CALL INITPOST_GFS_NETCDF(ncid3d) ELSE PRINT*,'POST does not have netcdf option for model,',MODELNAME,' STOPPING,' @@ -781,8 +785,7 @@ PROGRAM WRFPOST END IF ! use netcdf_parallel library to read fv3 output ELSE IF(TRIM(IOFORM) == 'netcdfpara') THEN - spval = 9.99e20 - print*,' CALLING INITPOST_GFS_NETCDF_PARA',timef() + print*,'CALLING INITPOST_GFS_NETCDF_PARA' CALL INITPOST_GFS_NETCDF_PARA(ncid3d) ELSE IF(TRIM(IOFORM) == 'binarympiio') THEN IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR' .OR. MODELNAME == 'NMM') THEN @@ -804,7 +807,6 @@ PROGRAM WRFPOST CALL INITPOST_NEMS(NREC,nfile) ELSE IF(MODELNAME == 'GFS') THEN ! CALL INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,nfile,ffile) - print*,' INITPOST_GFS_NEMS CALLED FOR GFS MODELNAME ' CALL INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,iostatusAER, & nfile,ffile,rfile) ELSE @@ -817,14 +819,12 @@ PROGRAM WRFPOST IF(MODELNAME == 'NMM') THEN ! close nemsio file for serial read call nemsio_close(nfile,iret=status) - print *,' INITPOST_NEMS_MPIIO called ' CALL INITPOST_NEMS_MPIIO() ELSE IF(MODELNAME == 'GFS') THEN ! close nemsio file for serial read call nemsio_close(nfile,iret=status) call nemsio_close(ffile,iret=status) call nemsio_close(rfile,iret=status) - print *,' INITPOST_NEMS_MPIIO called for GFS ' CALL INITPOST_GFS_NEMS_MPIIO(iostatusAER) ELSE PRINT*,'POST does not have nemsio mpi option for model,',MODELNAME, & @@ -844,24 +844,17 @@ PROGRAM WRFPOST PRINT*,'UNKNOWN MODEL OUTPUT FORMAT, STOPPING' STOP 9999 END IF - INITPOST_tim = INITPOST_tim +(timef() - btim) - time_initpost = time_initpost + timef() + INITPOST_tim = INITPOST_tim +(mpi_wtime() - btim) IF(ME == 0)THEN - WRITE(6,*)'WRFPOST: INITIALIZED POST COMMON BLOCKS', time_initpost,initpost_tim + WRITE(6,*)'WRFPOST: INITIALIZED POST COMMON BLOCKS' ENDIF - ta=timef() - call mpi_barrier(mpi_comm_comp,ierr) - tb=timef() - if(me .eq. 0) print *,' BARRIER 1,',tb-ta ! ! IF GRIB2 read out post aviable fields xml file and post control file ! if(grib == "grib2") then -! btim=timef() - ta=timef() + btim=mpi_wtime() call READ_xml() - READxml_tim = READxml_tim + (timef() - btim) - if(me .eq. 0) print *,' readxml_tim', timef()-ta,timef() + READxml_tim = READxml_tim + (mpi_wtime() - btim) endif ! ! LOOP OVER THE OUTPUT GRID(S). FIELD(S) AND OUTPUT GRID(S) ARE SPECIFIED @@ -893,12 +886,10 @@ PROGRAM WRFPOST ! (2) WRITE FIELD TO OUTPUT FILE IN GRIB. ! ! if (ieof == 0) then - t1=timef() ! CALL PROCESS(kth,kpv,th(1:kth),pv(1:kpv),iostatusD3D) ! IF(ME == 0)THEN - t2=timef() -! WRITE(6,*)' WRFPOST: PREPARE TO PROCESS NEXT GRID',t2-t1,t2-btim - +! WRITE(6,*)' ' +! WRITE(6,*)'WRFPOST: PREPARE TO PROCESS NEXT GRID' ! ENDIF ! endif ! @@ -911,7 +902,6 @@ PROGRAM WRFPOST if (me==0) write(0,*) ' in WRFPOST OUTFORM= ',grib if (me==0) write(0,*) ' GRIB1 IS NOT SUPPORTED ANYMORE' if (grib == "grib2") then - tf=timef() do while (npset < num_pset) npset = npset+1 if (me==0) write(0,*)' in WRFPOST npset=',npset,' num_pset=',num_pset @@ -932,28 +922,21 @@ PROGRAM WRFPOST if (me==0) write(0,*)'get_postfilename,post_fname=',trim(post_fname), & 'npset=',npset, 'num_pset=',num_pset, & 'iSF_SURFACE_PHYSICS=',iSF_SURFACE_PHYSICS - if(me .eq. 0) print *,' after postfiename time ',timef() ! ! PROCESS SELECTED FIELDS. FOR EACH SELECTED FIELD/LEVEL ! WE GO THROUGH THE FOLLOWING STEPS: ! (1) COMPUTE FIELD IF NEED BE ! (2) WRITE FIELD TO OUTPUT FILE IN GRIB. ! - t1=timef() - print *,' TIMEF BEFORE PROCESS',t1 CALL PROCESS(kth,kpv,th(1:kth),pv(1:kpv),iostatusD3D) IF(ME == 0) WRITE(6,*)'WRFPOST: PREPARE TO PROCESS NEXT GRID' ! ! write(0,*)'enter gribit2 before mpi_barrier' call mpi_barrier(mpi_comm_comp,ierr) - t2=timef() - if(me .eq. 0) print *,' PROCESS NEXT GRID',t2-t1,t2-btim ! if(me==0)call w3tage('bf grb2 ') ! write(0,*)'enter gribit2 after mpi barrier' - tc=timef() call gribit2(post_fname) - td=timef() deallocate(datapd) deallocate(fld_info) ! @@ -970,10 +953,7 @@ PROGRAM WRFPOST WRITE(6,*)' ' WRITE(6,*)'ALL GRIDS PROCESSED.' WRITE(6,*)' ' - print 305,' GWVX POSTIO compute and initialization TIME ',timef()-tf,time_initpost,initpost_tim - 305 format(a40,3f20.5) ENDIF - ! call DE_ALLOCATE @@ -981,21 +961,23 @@ PROGRAM WRFPOST 1000 CONTINUE !exp call ext_ncd_ioclose ( DataHandle, Status ) ! - if(me .eq. 0) then - print*, 'INITPOST_tim = ', INITPOST_tim*1.0e-3 - print*, 'MDLFLD_tim = ', ETAFLD2_tim*1.0e-3 - print*, 'MDL2P_tim = ',ETA2P_tim *1.0e-3 - print*, 'MDL2SIGMA_tim = ',MDL2SIGMA_tim *1.0e-3 - print*, 'SURFCE_tim = ',SURFCE2_tim*1.0e-3 - print*, 'CLDRAD_tim = ',CLDRAD_tim *1.0e-3 - print*, 'MISCLN_tim = ',MISCLN_tim*1.0e-3 - print*, 'FIXED_tim = ',FIXED_tim*1.0e-3 - print*, 'Total time = ',(timef() - btim) * 1.0e-3 - print*, 'Time for OUTPUT = ',time_output - print*, 'Time for INITPOST = ',time_initpost - print*, 'Time for READxml = ',READxml_tim * 1.0e-3 - endif - + IF(ME == 0) THEN + print*, 'INITPOST_tim = ', INITPOST_tim + print*, 'MDLFLD_tim = ', ETAFLD2_tim + print*, 'MDL2P_tim = ',ETA2P_tim + print*, 'MDL2SIGMA_tim = ',MDL2SIGMA_tim + print*, 'MDL2AGL_tim = ',MDL2AGL_tim + print*, 'SURFCE_tim = ',SURFCE2_tim + print*, 'CLDRAD_tim = ',CLDRAD_tim + print*, 'MISCLN_tim = ',MISCLN_tim + print*, 'MDL2STD_tim = ',MDL2STD_tim + print*, 'FIXED_tim = ',FIXED_tim + print*, 'MDL2THANDPV_tim = ',MDL2THANDPV_tim + print*, 'CALRAD_WCLOUD_tim = ',CALRAD_WCLOUD_tim + print*, 'Total time = ',(mpi_wtime() - bbtim) + print*, 'Time for OUTPUT = ',time_output + print*, 'Time for READxml = ',READxml_tim + endif ! ! END OF PROGRAM. ! @@ -1009,10 +991,10 @@ PROGRAM WRFPOST ! ! ! - call summary() +! call summary() + if (me == 0) CALL W3TAGE('UNIFIED_POST') CALL MPI_FINALIZE(IERR) - CALL W3TAGE('UNIFIED_POST') STOP 0 diff --git a/sorc/ncep_post.fd/grib2_module.f b/sorc/ncep_post.fd/grib2_module.f index f32c2bff1..47bf52965 100644 --- a/sorc/ncep_post.fd/grib2_module.f +++ b/sorc/ncep_post.fd/grib2_module.f @@ -206,7 +206,6 @@ subroutine gribit2(post_fname) character(255),intent(in) :: post_fname ! !------- local variables - real*8 timef,ta,tb,tc,td,te,tf,tg,th integer i,j,k,n,nm,nprm,nlvl,fldlvl1,fldlvl2,cstart,cgrblen,ierr integer nf,nfpe,nmod integer fh, clength,lunout @@ -353,11 +352,8 @@ subroutine gribit2(post_fname) allocate(datafldtmp(im_jm*nfld_pe(me+1)) ) allocate(datafld(im_jm,nfld_pe(me+1)) ) ! - ta=timef() call mpi_alltoallv(datapd,iscnt,isdsp,MPI_REAL, & datafldtmp,ircnt,irdsp,MPI_REAL,MPI_COMM_COMP,ierr) - tb=timef() - if(me .eq. 0) print *,' GWVX GRIBIT2 alltoall ',tb-ta ! !--- re-arrange the data datafld=0. @@ -411,12 +407,8 @@ subroutine gribit2(post_fname) ! !--- generate grib2 message --- ! - ta=timef() call gengrb2msg(idisc,icatg, iparm,nprm,nlvl,fldlvl1,fldlvl2,ntrange, & leng_time_range_stat,datafld(:,i),cgrib(cstart),clength) - tb=timef() - if(me .eq. 0) print 301,' GWVX GRIB2 WRITE ',tb-ta,timef() - 301 format(a25,2f10.3) cstart=cstart+clength ! else From 25bf506e4fc5b9b6763b1190b81a34f1d4b429b7 Mon Sep 17 00:00:00 2001 From: George Vandenberghe Date: Tue, 25 May 2021 18:53:59 +0000 Subject: [PATCH 09/77] added ctlblk change to support ista and iend partial I dimensons --- sorc/ncep_post.fd/CTLBLK.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sorc/ncep_post.fd/CTLBLK.f b/sorc/ncep_post.fd/CTLBLK.f index 74e48a718..3e872ad41 100644 --- a/sorc/ncep_post.fd/CTLBLK.f +++ b/sorc/ncep_post.fd/CTLBLK.f @@ -54,7 +54,7 @@ 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, & + integer :: NUM_PROCS,ME,JSTA,JEND,ista,iend,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, & MPI_COMM_COMP, IM,JM,LM,NSOIL,LP1,LM1,IM_JM, & From 37bc963fed6075b00fdb04a6210946afa2a9a565 Mon Sep 17 00:00:00 2001 From: George Vandenberghe Date: Tue, 25 May 2021 19:18:25 +0000 Subject: [PATCH 10/77] added para_range2 to PARA_RANGE.f to support 2D decomposition --- sorc/ncep_post.fd/PARA_RANGE.f | 38 ++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/sorc/ncep_post.fd/PARA_RANGE.f b/sorc/ncep_post.fd/PARA_RANGE.f index 404e0a41d..bf353d882 100644 --- a/sorc/ncep_post.fd/PARA_RANGE.f +++ b/sorc/ncep_post.fd/PARA_RANGE.f @@ -46,4 +46,42 @@ SUBROUTINE PARA_RANGE (N1,N2,NPROCS,IRANK,ISTA,IEND) if ( iwork2 > irank ) iend = iend + 1 return end +!! +!! USAGE: CALL PARA_RANGE2(N1,N2,NPROCS,IRANK,ISTA,IEND)(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) + 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 + From b488901956ec759e32acb92fc6483a48013ba055 Mon Sep 17 00:00:00 2001 From: George Vandenberghe Date: Thu, 27 May 2021 16:53:28 +0000 Subject: [PATCH 11/77] Modified MPI_FIRST.f to support a 2D decomposition but the actual numbers used remain the 1D special case and the changes just add two more indices for start and end I domains and logic to convert scatter counts and displacements to the product of the I and J subdomain sizes rather than I full domain x J subdomain. --- sorc/ncep_post.fd/MPI_FIRST.f | 29 ++++++++++++++++++++++++----- 1 file changed, 24 insertions(+), 5 deletions(-) diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 920f78e18..c431ec572 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -82,7 +82,7 @@ SUBROUTINE MPI_FIRST() pp10cb, ti use soil, only: smc, stc, sh2o, sldpth, rtdpth, sllevel use masks, only: htm, vtm, hbm2, sm, sice, lmh, gdlat, gdlon, dx, dy, lmv - use ctlblk_mod, only: me, num_procs, jm, jsta, jend, jsta_m, jsta_m2, & + use ctlblk_mod, only: me, num_procs, jm, jsta, jend, jsta_m, jsta_m2,ista,iend , & jend_m, jend_m2, iup, idn, icnt, im, idsp, jsta_2l, jend_2u, & jvend_2u, lm, lp1, jsta_2l, jend_2u, nsoil, nbin_du, nbin_ss, & nbin_bc, nbin_oc, nbin_su @@ -91,11 +91,14 @@ SUBROUTINE MPI_FIRST() ! use params_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none + ! include 'mpif.h' ! integer ierr,i,jsx,jex + integer isumm ! + isumm=0 if ( me == 0 ) then ! print *, ' NUM_PROCS = ',num_procs end if @@ -116,7 +119,18 @@ SUBROUTINE MPI_FIRST() ! ! global loop ranges ! - call para_range(1,jm,num_procs,me,jsta,jend) +! call para_range(1,jm,num_procs,me,jsta,jend) +! GWVX temporary documentation +! para_range2 supports a 2D decomposition. The rest of the post +! supports 1D still and the call here is the special case where each +! processor gets all of the longitudes in the latitude 1D subdomain +! jsta:jend. The X decomposition will be specified by the third +! argument (currently 1) and the Y decoposition will be specified by +! the fourth argument (currently all of the ranks) When X is +! subdivided the third and fourth arguments will have to be integral +! factors of num_procs and on 5/27/21 I am still working out a general +! way to do this if the user doesn't select the factors + call para_range2(im,jm,1,num_procs,me,ista,iend,jsta,jend) jsta_m = jsta jsta_m2 = jsta jend_m = jend @@ -149,9 +163,14 @@ SUBROUTINE MPI_FIRST() ! 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 +! call para_range(1,jm,num_procs,i,jsx,jex) + call para_range2(im,jm,1,num_procs,i,ista,iend,jsx,jex) +! icnt(i) = (jex-jsx+1)*im + icnt(i) = (jex-jsx+1)*(iend-ista+1) + +! idsp(i) = (jsx-1)*im + idsp(i)=isumm + isumm=isumm+(jex-jsx+1)*(iend-ista+1) if ( me == 0 ) then print *, ' i, icnt(i),idsp(i) = ',i,icnt(i), & idsp(i) From d7c4ec8c34ddeadb3c02fb86dd3328324ebc4116 Mon Sep 17 00:00:00 2001 From: George Vandenberghe Date: Tue, 1 Jun 2021 15:11:38 +0000 Subject: [PATCH 12/77] Added support for halo settings of 2D boundaries i.e ista_2l to match the 1D analogs long present in the source 6/1/2021 --- sorc/ncep_post.fd/CTLBLK.f | 10 +++++++--- sorc/ncep_post.fd/MPI_FIRST.f | 4 +++- sorc/ncep_post.fd/PARA_RANGE.f | 4 ++-- 3 files changed, 12 insertions(+), 6 deletions(-) diff --git a/sorc/ncep_post.fd/CTLBLK.f b/sorc/ncep_post.fd/CTLBLK.f index 3e872ad41..fdd618bf3 100644 --- a/sorc/ncep_post.fd/CTLBLK.f +++ b/sorc/ncep_post.fd/CTLBLK.f @@ -54,9 +54,13 @@ 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,ista,iend,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), & + 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, & lsm,lsmp1 !comm mpi ! diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index c431ec572..ff2d7f276 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -85,7 +85,9 @@ SUBROUTINE MPI_FIRST() use ctlblk_mod, only: me, num_procs, jm, jsta, jend, jsta_m, jsta_m2,ista,iend , & jend_m, jend_m2, iup, idn, icnt, im, idsp, jsta_2l, jend_2u, & jvend_2u, lm, lp1, jsta_2l, jend_2u, nsoil, nbin_du, nbin_ss, & - nbin_bc, nbin_oc, nbin_su + nbin_bc, nbin_oc, nbin_su, & + ISTA_M,IEND_M,ISTA_M2,IEND_M2, & + ISTA_2L, IEND_2U,IVEND_2U ! ! use params_mod diff --git a/sorc/ncep_post.fd/PARA_RANGE.f b/sorc/ncep_post.fd/PARA_RANGE.f index bf353d882..a416bc59c 100644 --- a/sorc/ncep_post.fd/PARA_RANGE.f +++ b/sorc/ncep_post.fd/PARA_RANGE.f @@ -47,13 +47,13 @@ SUBROUTINE PARA_RANGE (N1,N2,NPROCS,IRANK,ISTA,IEND) return end !! -!! USAGE: CALL PARA_RANGE2(N1,N2,NPROCS,IRANK,ISTA,IEND)(A) +!! USAGE: CALL PARA_RANGE2(N1,N2,NX,NY,NRANK,ISTA,IEND,JSTA,JEND)(A) !! INPUT ARGUMENT LIST: !! N1 - 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 +!! NX * NY should be the total number of MPI procs !! NRANK - MY TAKS ID !! !! OUTPUT ARGUMENT LIST: From a508840ed0f921df9183c7fe6de45d93ccbb1714 Mon Sep 17 00:00:00 2001 From: George Vandenberghe Date: Wed, 2 Jun 2021 20:48:52 +0000 Subject: [PATCH 13/77] Added definitions for ista_2u, and ista_2u in MPI_FIRST.f --- sorc/ncep_post.fd/MPI_FIRST.f | 3 +++ 1 file changed, 3 insertions(+) diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index ff2d7f276..fd4e845a1 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -186,6 +186,9 @@ SUBROUTINE MPI_FIRST() ! special for c-grid v jvend_2u = min(jend + 2, jm+1 ) ! special for c-grid v + ista_2l=max(ista-2,1) + iend_2u=min(iend+2,im) + ivend_2u = min(iend + 2, im+1 ) ! print *, ' me, jvend_2u = ',me,jvend_2u ! ! allocate arrays From 54f4e920dd9b449c23bd281c7c8489260e899aa2 Mon Sep 17 00:00:00 2001 From: George Vandenberghe Date: Thu, 3 Jun 2021 13:59:30 +0000 Subject: [PATCH 14/77] Reshaped arrays in MDL2FLD.f to support 2D decomposition. Modified TWO (only) loops to try thie --- sorc/ncep_post.fd/MDLFLD.f | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/sorc/ncep_post.fd/MDLFLD.f b/sorc/ncep_post.fd/MDLFLD.f index b85e17a11..fbb5892cb 100644 --- a/sorc/ncep_post.fd/MDLFLD.f +++ b/sorc/ncep_post.fd/MDLFLD.f @@ -96,7 +96,8 @@ 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 + me, dt, avrain, theat, ifhr, ifmin, avcnvc, lp1, im, jm, & + ista, iend, ista_2l, iend_2u use rqstfld_mod, only: iget, id, lvls, iavblfld, lvlsxml use gridspec_mod, only: gridtype,maptype,dxval use upp_physics, only: CALRH, CALCAPE @@ -128,7 +129,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, & @@ -882,7 +883,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. & @@ -3660,8 +3661,9 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,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 @@ -3669,8 +3671,9 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,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 @@ -3811,7 +3814,7 @@ SUBROUTINE MDLFLD ! IF (IGET(344)>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 From c3987ee8ee843f734736710a84f4fb83e9b7c513 Mon Sep 17 00:00:00 2001 From: Wen Meng Date: Tue, 22 Jun 2021 16:12:54 +0000 Subject: [PATCH 15/77] Remove TIMEF.f. --- sorc/ncep_post.fd/TIMEF.f | 22 ---------------------- 1 file changed, 22 deletions(-) delete mode 100644 sorc/ncep_post.fd/TIMEF.f diff --git a/sorc/ncep_post.fd/TIMEF.f b/sorc/ncep_post.fd/TIMEF.f deleted file mode 100644 index e2cae9f44..000000000 --- a/sorc/ncep_post.fd/TIMEF.f +++ /dev/null @@ -1,22 +0,0 @@ -! function written early Dec. 1999 by M. Pyle to support workstation -! Eta for users with etime but not timef functionality (like certain -!mp HPs) Designed to duplicate timef (elapsed time in milliseconds) -! - function timef() - use mpi - implicit none - real *8 et(2),rtc - data et/0.0,0.0/ - real*8 timef, etime - if(et(1) .eq. 0) et(1)=mpi_wtime() - et(2)=mpi_wtime() - timef=(et(2)-et(1)) -! timef=(et(2)-et(1))*1.e3 -! timef=mpi_wtime() *1.e3 -ti - end - - function rtcfake() - real*8 rtc, etime - rtcfake=mpi_wtime() *1.e3 -! rtcfake=rtc*1.e3 - end From 9f6ce39c263b85824f4955702e36d3669e0a03aa Mon Sep 17 00:00:00 2001 From: wx22mj Date: Sat, 3 Jul 2021 01:33:41 +0000 Subject: [PATCH 16/77] 20210702 JesseMeng modify MPI_FIRST.f MDLFLD.f for 2D decomposition --- sorc/ncep_post.fd/MDLFLD.f | 890 ++++++++++++++++++---------------- sorc/ncep_post.fd/MPI_FIRST.f | 15 +- 2 files changed, 493 insertions(+), 412 deletions(-) diff --git a/sorc/ncep_post.fd/MDLFLD.f b/sorc/ncep_post.fd/MDLFLD.f index fbb5892cb..4f3b7f1d2 100644 --- a/sorc/ncep_post.fd/MDLFLD.f +++ b/sorc/ncep_post.fd/MDLFLD.f @@ -120,7 +120,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. @@ -160,8 +160,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 +186,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,27 +196,28 @@ 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) THEN CALL NGMSLP !$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 @@ -231,7 +232,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 @@ -259,7 +260,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 ! @@ -277,7 +278,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 @@ -313,7 +314,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) @@ -366,7 +367,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 @@ -493,7 +494,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 @@ -521,7 +522,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 @@ -560,7 +561,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 @@ -568,7 +569,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 @@ -586,7 +587,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 @@ -618,7 +619,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. @@ -735,7 +736,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. @@ -918,7 +919,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 @@ -926,11 +927,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 @@ -945,7 +947,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 @@ -954,11 +956,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 @@ -970,9 +973,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 @@ -981,11 +984,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 @@ -999,7 +1003,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 @@ -1008,11 +1012,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 @@ -1026,7 +1031,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 @@ -1035,11 +1040,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 @@ -1053,7 +1059,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 @@ -1062,11 +1068,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 @@ -1080,7 +1087,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 @@ -1089,11 +1096,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 @@ -1107,7 +1115,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 @@ -1116,11 +1124,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 @@ -1134,7 +1143,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 @@ -1143,11 +1152,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 @@ -1159,7 +1169,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 @@ -1168,7 +1178,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 @@ -1179,7 +1189,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 @@ -1188,7 +1198,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 @@ -1200,7 +1210,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 @@ -1210,11 +1220,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 @@ -1228,7 +1239,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 @@ -1240,11 +1251,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 @@ -1267,14 +1279,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 @@ -1285,11 +1297,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 @@ -1304,7 +1317,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 @@ -1312,11 +1325,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 @@ -1330,7 +1344,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 @@ -1338,11 +1352,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 @@ -1356,7 +1371,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 @@ -1364,11 +1379,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 @@ -1383,7 +1399,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 @@ -1391,11 +1407,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 @@ -1409,7 +1426,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 @@ -1417,11 +1434,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 @@ -1435,7 +1453,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 @@ -1443,11 +1461,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 @@ -1461,7 +1480,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 ! @@ -1940,12 +1973,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 ! @@ -1955,12 +1988,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 ! @@ -1971,7 +2004,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 @@ -1979,11 +2012,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 @@ -1997,7 +2031,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 @@ -2005,11 +2039,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 @@ -2023,7 +2058,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 @@ -2031,11 +2066,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 @@ -2054,9 +2090,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 @@ -2231,11 +2271,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 @@ -2248,7 +2289,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 @@ -2261,11 +2302,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 @@ -2278,7 +2320,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 @@ -2291,11 +2333,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 @@ -2308,7 +2351,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 @@ -2321,11 +2364,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 @@ -2338,7 +2382,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 @@ -2351,11 +2395,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 @@ -2368,7 +2413,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 @@ -2380,11 +2425,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 @@ -2397,7 +2443,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 @@ -2409,11 +2455,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 @@ -2426,7 +2473,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 @@ -2438,11 +2485,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 @@ -2455,7 +2503,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 @@ -2467,11 +2515,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 @@ -2484,7 +2533,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 @@ -2496,11 +2545,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 @@ -2513,7 +2563,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 @@ -2526,11 +2576,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 @@ -2543,7 +2594,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) @@ -2785,7 +2842,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) ) @@ -2805,7 +2862,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) ) @@ -2815,7 +2872,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 @@ -2824,7 +2881,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 @@ -2834,11 +2891,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 @@ -2849,7 +2907,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) ) @@ -2886,11 +2945,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 @@ -2901,7 +2961,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) ) @@ -2911,11 +2971,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 @@ -2928,7 +2989,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) ) @@ -2938,11 +2999,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 @@ -2954,7 +3016,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 @@ -2967,11 +3029,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 @@ -2989,7 +3052,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 @@ -3018,7 +3081,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 @@ -3032,11 +3095,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 @@ -3046,7 +3110,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 @@ -3095,7 +3160,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 * & @@ -3108,11 +3173,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 @@ -3128,7 +3194,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 @@ -3196,7 +3262,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) @@ -3208,7 +3274,7 @@ SUBROUTINE MDLFLD ! DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(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) @@ -3220,7 +3286,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 @@ -3230,7 +3296,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 @@ -3238,7 +3304,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 ! @@ -3253,7 +3319,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 @@ -3261,7 +3327,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 @@ -3272,7 +3338,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 @@ -3287,7 +3353,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 @@ -3295,7 +3361,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 @@ -3306,7 +3372,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 @@ -3314,7 +3380,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))) @@ -3338,7 +3404,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 @@ -3349,7 +3415,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 @@ -3365,7 +3431,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 ! @@ -3382,14 +3448,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 ! @@ -3402,7 +3468,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 @@ -3413,7 +3479,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 @@ -3436,7 +3502,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 @@ -3444,11 +3510,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 @@ -3463,7 +3530,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 @@ -3471,11 +3538,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 @@ -3507,7 +3575,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 @@ -3515,11 +3583,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 @@ -3532,7 +3601,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 @@ -3586,10 +3655,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. @@ -3598,12 +3667,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 @@ -3632,11 +3701,11 @@ SUBROUTINE MDLFLD END DO - CALL U2H(GRID1(1,JSTA_2L),EGRID1) - CALL V2H(GRID2(1,JSTA_2L),EGRID2) + CALL U2H(GRID1(ista_2l,JSTA_2L),EGRID1) + CALL V2H(GRID2(ista_2l,JSTA_2L),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 @@ -3658,7 +3727,7 @@ 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,iend-ista+1 @@ -3668,7 +3737,7 @@ SUBROUTINE MDLFLD 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,iend-ista+1 @@ -3690,7 +3759,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) @@ -3710,11 +3779,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 @@ -3739,7 +3809,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 @@ -3748,14 +3818,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 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 @@ -3868,11 +3940,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 @@ -3881,7 +3954,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) @@ -3891,10 +3964,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 @@ -3907,7 +3980,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 @@ -3915,18 +3988,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 @@ -3934,17 +4008,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 @@ -3952,11 +4027,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 @@ -3979,7 +4055,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) @@ -4013,12 +4089,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/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index fd4e845a1..77b57b04a 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -97,10 +97,13 @@ SUBROUTINE MPI_FIRST() ! include 'mpif.h' ! - integer ierr,i,jsx,jex + integer ierr,i,jsx,jex,isx,iex integer isumm + integer numx !number of subdomain in x direction ! isumm=0 + numx=1 + if ( me == 0 ) then ! print *, ' NUM_PROCS = ',num_procs end if @@ -132,7 +135,8 @@ SUBROUTINE MPI_FIRST() ! subdivided the third and fourth arguments will have to be integral ! factors of num_procs and on 5/27/21 I am still working out a general ! way to do this if the user doesn't select the factors - call para_range2(im,jm,1,num_procs,me,ista,iend,jsta,jend) + ! call para_range2(im,jm,1,num_procs,me,ista,iend,jsta,jend) + call para_range2(im,jm,numx,num_procs/numx,me,ista,iend,jsta,jend) jsta_m = jsta jsta_m2 = jsta jend_m = jend @@ -166,13 +170,13 @@ SUBROUTINE MPI_FIRST() ! do i = 0, num_procs - 1 ! call para_range(1,jm,num_procs,i,jsx,jex) - call para_range2(im,jm,1,num_procs,i,ista,iend,jsx,jex) + call para_range2(im,jm,numx,num_procs/numx,i,isx,iex,jsx,jex) ! icnt(i) = (jex-jsx+1)*im - icnt(i) = (jex-jsx+1)*(iend-ista+1) + icnt(i) = (jex-jsx+1)*(iex-isx+1) ! idsp(i) = (jsx-1)*im idsp(i)=isumm - isumm=isumm+(jex-jsx+1)*(iend-ista+1) + isumm=isumm+(jex-jsx+1)*(iex-isx+1) if ( me == 0 ) then print *, ' i, icnt(i),idsp(i) = ',i,icnt(i), & idsp(i) @@ -199,5 +203,6 @@ SUBROUTINE MPI_FIRST() print *, ' me, jsta_2l, jend_2u = ',me,jsta_2l, jend_2u, & 'jvend_2u=',jvend_2u,'im=',im,'jm=',jm,'lm=',lm, & 'lp1=',lp1 + write(*,'(A,5I10)') 'MPI_FIRST me,jsta,jend,ista,iend,=',me,jsta,jend,ista,iend end From 9d9ef6a364f8761c65248a9a4b3ad5c689f3e404 Mon Sep 17 00:00:00 2001 From: Bo Cui Date: Tue, 6 Jul 2021 15:03:37 -0400 Subject: [PATCH 17/77] 20210706 BoCui modify INITPOST_GFS_NETCDF_PARA.f --- sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f | 520 ++++++++++--------- 1 file changed, 267 insertions(+), 253 deletions(-) diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f index 3f7cab8f7..e72c56df1 100644 --- a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f +++ b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f @@ -77,7 +77,8 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,& ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, & jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, & - nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER,rdaod + nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER,rdaod, & + ista, iend, ista_2l, iend_2u 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 @@ -161,8 +162,8 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(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) @@ -183,6 +184,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !*********************************************************************** ! START INIT HERE. ! + print*, 'BOCUI TEST INITPOST_GFS_NETCDF_PARA.f' WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NETCDF_PARA' WRITE(6,*)'me=',me, & 'jsta_2l=',jsta_2l,'jend_2u=', & @@ -193,7 +195,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$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 @@ -374,7 +376,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(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 @@ -385,7 +387,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(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 @@ -453,7 +455,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(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 @@ -465,13 +467,13 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(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 @@ -506,7 +508,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(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 @@ -518,13 +520,13 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(maxval(abs(dummy))1.0E6 .or. pint(1,jsta_2l,lp1)<50000.) & ! print*,'bad psfc ',i,j,pint(i,j,lp1) end do @@ -752,14 +754,14 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(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 pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) enddo enddo @@ -770,7 +772,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !compute pmid from averaged two layer pint do l=lm,1,-1 do j=jsta,jend - do i=1,im + do i=ista,iend pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) enddo enddo @@ -780,11 +782,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! dong set missing value for zint ! zint=spval VarName='hgtsfc' - call read_netcdf_2d_para(ncid3d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid3d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,zint(1,jsta_2l,lp1)) if(debugprint)print*,'sample ',VarName,' =',zint(isa,jsa,lp1) do j=jsta,jend - do i=1,im + do i=ista,iend if (zint(i,j,lp1) /= spval) then fis(i,j) = zint(i,j,lp1) * grav else @@ -795,7 +797,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) do l=lm,1,-1 do j=jsta,jend - do i=1,im + do i=ista,iend if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then !make sure delz is positive zint(i,j,l)=zint(i,j,l+1)+abs(buf3d(i,j,l)) @@ -810,7 +812,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) do l=lp1,1,-1 do j=jsta,jend - do i=1,im + do i=ista,iend alpint(i,j,l)=log(pint(i,j,l)) end do end do @@ -818,7 +820,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) do l=lm,1,-1 do j=jsta,jend - do i=1,im + do i=ista,iend if(zint(i,j,l+1)/=spval .and. zint(i,j,l)/=spval & .and. pmid(i,j,l)/=spval)then zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & @@ -912,20 +914,20 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !Set REF_10CM as missning since gfs doesn't ouput it do l=1,lm do j=jsta,jend - do i=1,im + do i=ista,iend REF_10CM(i,j,l)=spval enddo enddo enddo VarName='land' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sm) if(debugprint)print*,'sample ',VarName,' =',sm(im/2,(jsta+jend)/2) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j) enddo enddo @@ -933,7 +935,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! sea ice mask VarName = 'icec' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sice) if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa) @@ -947,7 +949,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0 enddo enddo @@ -955,54 +957,54 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! PBL height using nemsio VarName = 'hpbl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pblh) if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa) ! frictional velocity using nemsio VarName='fricv' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ustar) ! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa) ! roughness length using getgb VarName='sfcr' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,z0) ! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa) ! sfc exchange coeff VarName='sfexc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,SFCEXC) ! aerodynamic conductance VarName='acond' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,acond) if(debugprint)print*,'sample ',VarName,' = ',acond(isa,jsa) ! mid day avg albedo VarName='albdo_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgalbedo) if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 enddo enddo ! surface potential T using getgb VarName='tmpsfc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ths) ! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (ths(i,j) /= spval) then ! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa @@ -1034,12 +1036,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! convective precip in m per physics time step using getgb ! read 3 hour bucket VarName='cpratb_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcprate) ! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001) enddo enddo @@ -1049,11 +1051,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! read continuous bucket VarName='cprat_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcprate_cont) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgcprate_cont(i,j) /= spval) avgcprate_cont(i,j) = & avgcprate_cont(i,j) * (dtq2*0.001) enddo @@ -1064,11 +1066,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! precip rate in m per physics time step using getgb VarName='prateb_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgprec) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if(avgprec(i,j) /= spval)avgprec(i,j)=avgprec(i,j)*(dtq2*0.001) enddo enddo @@ -1078,12 +1080,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! prec = avgprec !set avg cprate to inst one to derive other fields VarName='prate_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgprec_cont) ! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgprec_cont(i,j) /=spval)avgprec_cont(i,j)=avgprec_cont(i,j) & * (dtq2*0.001) enddo @@ -1092,11 +1094,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample ',VarName,' = ',avgprec_cont(isa,jsa) ! precip rate in m per physics time step VarName='tprcp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,prec) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (prec(i,j) /= spval) prec(i,j)=prec(i,j)* (dtq2*0.001) & * 1000. / dtp enddo @@ -1104,11 +1106,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! convective precip rate in m per physics time step VarName='cnvprcp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,cprate) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (cprate(i,j) /= spval) then cprate(i,j) = max(0.,cprate(i,j)) * (dtq2*0.001) & * 1000. / dtp @@ -1151,18 +1153,18 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 2m T using nemsio VarName='tmp2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,tshltr) if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) ! inst snow water eqivalent using nemsio VarName='weasd' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sno) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j)==0.) sno(i,j) = spval enddo enddo @@ -1170,11 +1172,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! ave snow cover VarName='snowc_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,snoavg) ! snow cover is multipled by 100 in SURFCE before writing it out do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j)=spval if(snoavg(i,j)/=spval)snoavg(i,j)=snoavg(i,j)/100. end do @@ -1182,11 +1184,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! snow depth in mm using nemsio VarName='snod' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,si) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency @@ -1201,13 +1203,13 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 2m T using nemsio VarName='tmp2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,tshltr) if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) ! GFS does not have 2m pres, estimate it, also convert t to theta Do j=jsta,jend - Do i=1,im + do i=ista,iend PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta ! if (j == jm/2 .and. mod(i,50) == 0) @@ -1218,7 +1220,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 2m specific humidity using nemsio VarName='spfh2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,qshltr) if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa) @@ -1229,7 +1231,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction !!$omp parallel do private(i,j) ! do j=jsta,jend -! do i=1,im +! do i=ista,iend ! if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 ! enddo ! enddo @@ -1237,12 +1239,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged column cloud fractionusing nemsio VarName='tcdc_aveclm' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgtcdc) ! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01 enddo enddo @@ -1251,7 +1253,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! GFS probably does not use zenith angle !$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 enddo @@ -1259,12 +1261,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! maximum snow albedo in fraction using nemsio VarName='snoalb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,mxsnal) ! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01 enddo enddo @@ -1273,7 +1275,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! GFS probably does not use sigt4, set it to sig*t^4 !$omp parallel do private(i,j,tlmh) Do j=jsta,jend - Do i=1,im + do i=ista,iend TLMH = T(I,J,LM) * T(I,J,LM) Sigt4(i,j) = 5.67E-8 * TLMH * TLMH End do @@ -1284,7 +1286,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! GFS does not have inst cloud fraction for high, middle, and low cloud !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u cfrach(i,j) = spval cfracl(i,j) = spval cfracm(i,j) = spval @@ -1293,12 +1295,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! ave high cloud fraction using nemsio VarName='tcdc_avehcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcfrach) ! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01 enddo enddo @@ -1306,12 +1308,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! ave low cloud fraction using nemsio VarName='tcdc_avelcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcfracl) ! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01 enddo enddo @@ -1319,12 +1321,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! ave middle cloud fraction using nemsio VarName='tcdc_avemcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcfracm) ! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01 enddo enddo @@ -1332,12 +1334,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst convective cloud fraction using nemsio VarName='tcdccnvcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,cnvcfr) ! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01 enddo enddo @@ -1345,11 +1347,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! slope type using nemsio VarName='sltyp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,buf) !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=1,im + do i=ista_2l,iend_2u if (buf(i,j) < spval) then islope(i,j) = nint(buf(i,j)) else @@ -1361,11 +1363,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! plant canopy sfc wtr in m VarName='cnwat' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,cmc) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001 if (sm(i,j) /= 0.0) cmc(i,j) = spval enddo @@ -1374,18 +1376,18 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u grnflx(i,j) = spval ! GFS does not have inst ground heat flux enddo enddo ! frozen precip fraction using nemsio VarName='cpofp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sr) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if(sr(i,j) /= spval) then !set range within (0,1) sr(i,j)=min(1.,max(0.,sr(i,j))) @@ -1395,22 +1397,22 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! sea ice skin temperature VarName='tisfc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ti) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sice(i,j) == spval .or. sice(i,j) == 0.) ti(i,j)=spval enddo enddo ! vegetation fraction in fraction. using nemsio VarName='veg' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,vegfrc) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (vegfrc(i,j) /= spval) then vegfrc(i,j) = vegfrc(i,j) * 0.01 else @@ -1421,7 +1423,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) vegfrc(i,j) = spval enddo enddo @@ -1436,48 +1438,48 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! liquid volumetric soil mpisture in fraction using nemsio VarName='soill1' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sh2o(1,jsta_2l,1)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) sh2o(i,j,1) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1) VarName='soill2' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sh2o(1,jsta_2l,2)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) sh2o(i,j,2) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2) VarName='soill3' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sh2o(1,jsta_2l,3)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) sh2o(i,j,3) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3) VarName='soill4' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sh2o(1,jsta_2l,4)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) sh2o(i,j,4) = spval enddo enddo @@ -1485,48 +1487,48 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! volumetric soil moisture using nemsio VarName='soilw1' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smc(1,jsta_2l,1)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) smc(i,j,1) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1) VarName='soilw2' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smc(1,jsta_2l,2)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) smc(i,j,2) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2) VarName='soilw3' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smc(1,jsta_2l,3)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) smc(i,j,3) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3) VarName='soilw4' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smc(1,jsta_2l,4)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) smc(i,j,4) = spval enddo enddo @@ -1534,12 +1536,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! soil temperature using nemsio VarName='soilt1' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,stc(1,jsta_2l,1)) ! mask open water areas, combine with sea ice tmp !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,1) = spval !if (sm(i,j) /= 0.0) stc(i,j,1) = spval enddo @@ -1547,12 +1549,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1) VarName='soilt2' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,stc(1,jsta_2l,2)) ! mask open water areas, combine with sea ice tmp !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,2) = spval !if (sm(i,j) /= 0.0) stc(i,j,2) = spval enddo @@ -1560,12 +1562,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2) VarName='soilt3' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,stc(1,jsta_2l,3)) ! mask open water areas, combine with sea ice tmp !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,3) = spval !if (sm(i,j) /= 0.0) stc(i,j,3) = spval enddo @@ -1573,12 +1575,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3) VarName='soilt4' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,stc(1,jsta_2l,4)) ! mask open water areas, combine with sea ice tmp !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,4) = spval !if (sm(i,j) /= 0.0) stc(i,j,4) = spval enddo @@ -1587,7 +1589,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 ncfrcv(i,j) = 1.0 acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 @@ -1601,27 +1603,27 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged incoming sfc longwave VarName='dlwrf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwin) ! inst incoming sfc longwave VarName='dlwrf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,rlwin) ! time averaged outgoing sfc longwave VarName='ulwrf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwout) ! inst outgoing sfc longwave VarName='ulwrf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,radot) ! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j) enddo enddo @@ -1629,7 +1631,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged outgoing model top longwave using gfsio VarName='ulwrf_avetoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwtoa) ! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa) @@ -1639,40 +1641,40 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged incoming sfc shortwave VarName='dswrf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswin) ! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa) ! inst incoming sfc shortwave VarName='dswrf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,rswin) ! inst incoming clear sky sfc shortwave VarName='csdlf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,rswinc) ! time averaged incoming sfc uv-b using getgb VarName='duvb_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,auvbin) ! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa) ! time averaged incoming sfc clear sky uv-b using getgb VarName='cduvb_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,auvbinc) ! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa) ! time averaged outgoing sfc shortwave using gfsio VarName='uswrf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswout) ! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j) enddo enddo @@ -1680,30 +1682,30 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst outgoing sfc shortwave using gfsio VarName='uswrf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,rswout) ! time averaged model top incoming shortwave VarName='dswrf_avetoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswintoa) ! if(debugprint)print*,'sample l',VarName,' = ',1,aswintoa(isa,jsa) ! time averaged model top outgoing shortwave VarName='uswrf_avetoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswtoa) ! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa) ! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux ! has reversed sign convention using gfsio VarName='shtfl_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sfcshx) ! where (sfcshx /= spval)sfcshx=-sfcshx !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j) enddo enddo @@ -1711,11 +1713,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst surface sensible heat flux VarName='shtfl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,twbs) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (twbs(i,j) /= spval) twbs(i,j) = -twbs(i,j) enddo enddo @@ -1727,12 +1729,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged surface latent heat flux, multiplied by -1 because wrf model flux ! has reversed sign vonvention using gfsio VarName='lhtfl_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sfclhx) ! where (sfclhx /= spval)sfclhx=-sfclhx !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j) enddo enddo @@ -1740,11 +1742,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst surface latent heat flux VarName='lhtfl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,qwbs) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (qwbs(i,j) /= spval) qwbs(i,j) = -qwbs(i,j) enddo enddo @@ -1753,39 +1755,39 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst aod550 optical depth if(rdaod) then VarName='aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aod550) VarName='du_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,du_aod550) VarName='ss_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ss_aod550) VarName='su_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,su_aod550) VarName='oc_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,oc_aod550) VarName='bc_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,bc_aod550) endif !end if rdaod ! time averaged ground heat flux using nemsio VarName='gflux_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,subshx) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval enddo enddo @@ -1793,25 +1795,25 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst ground heat flux using nemsio VarName='gflux' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,grnflx) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval enddo enddo ! time averaged zonal momentum flux using gfsio VarName='uflx_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sfcux) ! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa) ! time averaged meridional momentum flux using nemsio VarName='vflx_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sfcvx) ! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa) @@ -1831,31 +1833,31 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u sfcuvx(i,j) = spval ! GFS does not use total momentum flux enddo enddo ! time averaged zonal gravity wave stress using nemsio VarName='u-gwd_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,gtaux) ! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa) ! time averaged meridional gravity wave stress using getgb VarName='v-gwd_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,gtauy) ! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa) ! time averaged accumulated potential evaporation VarName='pevpr_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgpotevp) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval enddo enddo @@ -1863,12 +1865,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst potential evaporation VarName='pevpr' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,potevp) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval enddo enddo @@ -1876,7 +1878,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) 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 ! GFS does not have temperature tendency due to long wave radiation rlwtt(i,j,l) = spval ! GFS does not have temperature tendency due to short wave radiation @@ -1897,11 +1899,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 10 m u using nemsio VarName='ugrd10m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,u10) do j=jsta,jend - do i=1,im + do i=ista,iend u10h(i,j)=u10(i,j) end do end do @@ -1909,11 +1911,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 10 m v using gfsio VarName='vgrd10m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,v10) do j=jsta,jend - do i=1,im + do i=ista,iend v10h(i,j)=v10(i,j) end do end do @@ -1921,7 +1923,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon VarName='vtype' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,buf) ! where (buf /= spval) ! ivgtyp=nint(buf) @@ -1930,7 +1932,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! end where !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=1,im + do i=ista_2l,iend_2u if (buf(i,j) < spval) then ivgtyp(i,j) = nint(buf(i,j)) else @@ -1942,11 +1944,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! soil type, it's in GFS surface file, hopefully will merge into gfsio soon VarName='sotyp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,buf) !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=1,im + do i=ista_2l,iend_2u if (buf(i,j) < spval) then isltyp(i,j) = nint(buf(i,j)) else @@ -1958,7 +1960,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u smstav(i,j) = spval ! GFS does not have soil moisture availability ! smstot(i,j) = spval ! GFS does not have total soil moisture sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation @@ -1974,7 +1976,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) 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 EL_PBL(i,j,l) = spval ! GFS does not have mixing length exch_h(i,j,l) = spval ! GFS does not output exchange coefficient enddo @@ -1989,19 +1991,19 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! l=1 ! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa) VarName='prescnvclt' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ptop) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend htop(i,j) = spval if(ptop(i,j) <= 0.0) ptop(i,j) = spval enddo enddo do j=jsta,jend - do i=1,im + do i=ista,iend if(ptop(i,j) < spval)then do l=1,lm if(ptop(i,j) <= pmid(i,j,l))then @@ -2018,18 +2020,18 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, ! will need to modify CLDRAD.f to use pressure directly instead of index VarName='prescnvclb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pbot) ! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend hbot(i,j) = spval if(pbot(i,j) <= 0.0) pbot(i,j) = spval enddo enddo do j=jsta,jend - do i=1,im + do i=ista,iend ! if(.not.lb(i,j))print*,'false bitmask for pbot at ' ! + ,i,j,pbot(i,j) if(pbot(i,j) < spval)then @@ -2047,85 +2049,85 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample hbot = ',hbot(isa,jsa) ! retrieve time averaged low cloud top pressure using nemsio VarName='pres_avelct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ptopl) ! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa) ! retrieve time averaged low cloud bottom pressure using nemsio VarName='pres_avelcb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pbotl) ! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa) ! retrieve time averaged low cloud top temperature using nemsio VarName='tmp_avelct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,Ttopl) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa) ! retrieve time averaged middle cloud top pressure using nemsio VarName='pres_avemct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ptopm) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa) ! retrieve time averaged middle cloud bottom pressure using nemsio VarName='pres_avemcb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pbotm) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa) ! retrieve time averaged middle cloud top temperature using nemsio VarName='tmp_avemct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,Ttopm) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa) ! retrieve time averaged high cloud top pressure using nemsio ********* VarName='pres_avehct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ptoph) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa) ! retrieve time averaged high cloud bottom pressure using nemsio VarName='pres_avehcb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pboth) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa) ! retrieve time averaged high cloud top temperature using nemsio VarName='tmp_avehct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,Ttoph) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa) ! retrieve boundary layer cloud cover using nemsio VarName='tcdc_avebndcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pblcfr) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa) ! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=1,im + do i=ista_2l,iend_2u if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01 enddo enddo ! retrieve cloud work function VarName='cwork_aveclm' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,cldwork) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa) ! accumulated total (base+surface) runoff VarName='watr_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,runoff) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) runoff(i,j) = spval enddo enddo @@ -2133,12 +2135,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve shelter max temperature using nemsio VarName='tmax_max2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,maxtshltr) ! retrieve shelter min temperature using nemsio VarName='tmin_min2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,mintshltr) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & ! 1,mintshltr(im/2,(jsta+jend)/2) @@ -2157,7 +2159,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u MAXRHSHLTR(i,j) = SPVAL MINRHSHLTR(i,j) = SPVAL enddo @@ -2165,18 +2167,18 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve ice thickness using nemsio VarName='icetk' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,dzice) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa) ! retrieve wilting point using nemsio VarName='wilt' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smcwlt) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) smcwlt(i,j) = spval enddo enddo @@ -2184,17 +2186,17 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve sunshine duration using nemsio VarName='sunsd_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,suntime) ! retrieve field capacity using nemsio VarName='fldcp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,fieldcapa) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) fieldcapa(i,j) = spval enddo enddo @@ -2202,147 +2204,147 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve time averaged surface visible beam downward solar flux VarName='vbdsf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avisbeamswin) l=1 ! retrieve time averaged surface visible diffuse downward solar flux VarName='vddsf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avisdiffswin) ! retrieve time averaged surface near IR beam downward solar flux VarName='nbdsf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,airbeamswin) ! retrieve time averaged surface near IR diffuse downward solar flux VarName='nddsf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,airdiffswin) ! retrieve time averaged surface clear sky outgoing LW VarName='csulf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwoutc) ! retrieve time averaged TOA clear sky outgoing LW VarName='csulftoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwtoac) ! retrieve time averaged surface clear sky outgoing SW VarName='csusf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswoutc) ! retrieve time averaged TOA clear sky outgoing LW VarName='csusftoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswtoac) ! retrieve time averaged surface clear sky incoming LW VarName='csdlf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwinc) ! retrieve time averaged surface clear sky incoming SW VarName='csdsf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswinc) ! retrieve shelter max specific humidity using nemsio VarName='spfhmax_max2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,maxqshltr) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', ! 1,maxqshltr(isa,jsa) ! retrieve shelter min temperature using nemsio VarName='spfhmin_min2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,minqshltr) ! retrieve storm runoff using nemsio VarName='ssrun_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,SSROFF) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) ssroff(i,j) = spval enddo enddo ! retrieve direct soil evaporation VarName='evbs_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgedir) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) avgedir(i,j) = spval enddo enddo ! retrieve CANOPY WATER EVAP VarName='evcw_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgecan) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) avgecan(i,j) = spval enddo enddo ! retrieve PLANT TRANSPIRATION VarName='trans_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgetrans) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) avgetrans(i,j) = spval enddo enddo ! retrieve snow sublimation VarName='sbsno_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgesnow) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval enddo enddo ! retrive total soil moisture VarName='soilm' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smstot) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) smstot(i,j) = spval enddo enddo ! retrieve snow phase change heat flux VarName='snohf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,snopcx) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) snopcx(i,j) = spval enddo enddo @@ -2351,7 +2353,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend HTOPD(i,j) = SPVAL HBOTD(i,j) = SPVAL HTOPS(i,j) = SPVAL @@ -2498,7 +2500,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) RETURN END - subroutine read_netcdf_3d_para(ncid,im,jm,jsta,jsta_2l,jend,jend_2u, & + subroutine read_netcdf_3d_para(ncid,im,jm,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,varname,buf,lm) use netcdf @@ -2508,8 +2510,9 @@ subroutine read_netcdf_3d_para(ncid,im,jm,jsta,jsta_2l,jend,jend_2u, & character(len=20),intent(in) :: varname real,intent(in) :: spval integer,intent(in) :: ncid,im,jm,lm,jsta_2l,jend_2u,jsta,jend - real,intent(out) :: buf(im,jsta_2l:jend_2u,lm) - integer :: varid,iret,jj,i,j,l,kk + integer,intent(in) :: ista_2l,iend_2u,ista,iend + real,intent(out) :: buf(ista_2l:iend_2u,jsta_2l:jend_2u,lm) + integer :: varid,iret,ii,jj,i,j,l,kk integer :: start(3), count(3), stride(3) iret = nf90_inq_varid(ncid,trim(varname),varid) @@ -2518,21 +2521,26 @@ subroutine read_netcdf_3d_para(ncid,im,jm,jsta,jsta_2l,jend,jend_2u, & !$omp parallel do private(i,j,l) do l=1,lm do j=jsta,jend - do i=1,im + do i=ista,iend buf(i,j,l)=spval enddo enddo enddo else - start = (/1,jsta,1/) +! start = (/1,jsta,1/) +! jj=jend-jsta+1 +! count = (/im,jj,lm/) +! iret = nf90_get_var(ncid,varid,buf(1:im,jsta:jend,1:lm),start=start,count=count) + start = (/ista,jsta,1/) jj=jend-jsta+1 - count = (/im,jj,lm/) - iret = nf90_get_var(ncid,varid,buf(1:im,jsta:jend,1:lm),start=start,count=count) + ii=iend-ista+1 + count = (/ii,jj,lm/) + iret = nf90_get_var(ncid,varid,buf(ista:iend,jsta:jend,1:lm),start=start,count=count) endif end subroutine read_netcdf_3d_para - subroutine read_netcdf_2d_para(ncid,im,jsta,jsta_2l,jend,jend_2u, & + subroutine read_netcdf_2d_para(ncid,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,buf) use netcdf @@ -2541,9 +2549,10 @@ subroutine read_netcdf_2d_para(ncid,im,jsta,jsta_2l,jend,jend_2u, & character(len=20),intent(in) :: VarName real,intent(in) :: spval - integer,intent(in) :: ncid,im,jsta_2l,jend_2u,jsta,jend - real,intent(out) :: buf(im,jsta_2l:jend_2u) - integer :: varid,iret,jj,i,j + integer,intent(in) :: ncid,jsta_2l,jend_2u,jsta,jend + integer,intent(in) :: ista_2l,iend_2u,ista,iend + real,intent(out) :: buf(ista_2l:iend_2u,jsta_2l:jend_2u) + integer :: varid,iret,ii,jj,i,j integer :: start(2), count(2) iret = nf90_inq_varid(ncid,trim(varname),varid) @@ -2551,15 +2560,20 @@ subroutine read_netcdf_2d_para(ncid,im,jsta,jsta_2l,jend,jend_2u, & print*,VarName," not found -Assigned missing values" !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend buf(i,j)=spval enddo enddo else - start = (/1,jsta/) +! start = (/1,jsta/) +! jj=jend-jsta+1 +! count = (/im,jj/) +! iret = nf90_get_var(ncid,varid,buf(:,jsta),start=start,count=count) + start = (/ista,jsta/) jj=jend-jsta+1 - count = (/im,jj/) - iret = nf90_get_var(ncid,varid,buf(:,jsta),start=start,count=count) + ii=iend-ista+1 + count = (/ii,jj/) + iret = nf90_get_var(ncid,varid,buf(ista:iend,jsta:jend),start=start,count=count) endif end subroutine read_netcdf_2d_para From 2ea27da89d74e473889c2d3282acdf67a244f54d Mon Sep 17 00:00:00 2001 From: wx22mj Date: Wed, 7 Jul 2021 19:18:55 +0000 Subject: [PATCH 18/77] 20210707 JesseMeng modified grib2_module.f for 2d decomposition --- sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f | 520 +++++++++---------- sorc/ncep_post.fd/MPI_FIRST.f | 2 +- sorc/ncep_post.fd/WRFPOST.f | 9 +- sorc/ncep_post.fd/grib2_module.f | 35 +- 4 files changed, 289 insertions(+), 277 deletions(-) diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f index e72c56df1..3f7cab8f7 100644 --- a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f +++ b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f @@ -77,8 +77,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,& ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, & jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, & - nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER,rdaod, & - ista, iend, ista_2l, iend_2u + nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER,rdaod use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, & dxval, dyval, truelat2, truelat1, psmapf, cenlat,lonstartv, lonlastv, cenlonv, & latstartv, latlastv, cenlatv,latstart_r,latlast_r,lonstart_r,lonlast_r @@ -162,8 +161,8 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) real, dimension(lm+1) :: ak5, bk5 real*8, allocatable :: pm2d(:,:), pi2d(:,:) real, allocatable :: tmp(:) - 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) + real :: buf3d(im,jsta_2l:jend_2u,lm) ! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & ! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) @@ -184,7 +183,6 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !*********************************************************************** ! START INIT HERE. ! - print*, 'BOCUI TEST INITPOST_GFS_NETCDF_PARA.f' WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NETCDF_PARA' WRITE(6,*)'me=',me, & 'jsta_2l=',jsta_2l,'jend_2u=', & @@ -195,7 +193,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=ista_2l, iend_2u + do i=1,im buf(i,j) = spval enddo enddo @@ -376,7 +374,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i = ista_2l, iend_2u + do i = 1, im LMV(i,j) = lm LMH(i,j) = lm end do @@ -387,7 +385,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j,l) do l = 1, lm do j = jsta_2l, jend_2u - do i = ista_2l, iend_2u + do i = 1, im HTM (i,j,l) = 1.0 VTM (i,j,l) = 1.0 end do @@ -455,7 +453,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(numDims==1)then Status=nf90_get_var(ncid3d,varid,glon1d) do j=jsta,jend - do i=ista,iend + do i=1,im gdlon(i,j) = real(glon1d(i),kind=4) end do end do @@ -467,13 +465,13 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(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=ista,iend + do i=1,im gdlon(i,j) = real(dummy(i,j),kind=4)*180./pi end do end do else do j=jsta,jend - do i=ista,iend + do i=1,im gdlon(i,j) = real(dummy(i,j),kind=4) end do end do @@ -508,7 +506,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(numDims==1)then Status=nf90_get_var(ncid3d,varid,glat1d) do j=jsta,jend - do i=ista,iend + do i=1,im gdlat(i,j) = real(glat1d(j),kind=4) end do end do @@ -520,13 +518,13 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(maxval(abs(dummy))1.0E6 .or. pint(1,jsta_2l,lp1)<50000.) & ! print*,'bad psfc ',i,j,pint(i,j,lp1) end do @@ -754,14 +752,14 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) pt = ak5(1) do j=jsta,jend - do i=ista,iend + do i=1,im pint(i,j,1)= pt end do end do do l=2,lp1 do j=jsta,jend - do i=ista,iend + do i=1,im pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) enddo enddo @@ -772,7 +770,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !compute pmid from averaged two layer pint do l=lm,1,-1 do j=jsta,jend - do i=ista,iend + do i=1,im pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) enddo enddo @@ -782,11 +780,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! dong set missing value for zint ! zint=spval VarName='hgtsfc' - call read_netcdf_2d_para(ncid3d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid3d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,zint(1,jsta_2l,lp1)) if(debugprint)print*,'sample ',VarName,' =',zint(isa,jsa,lp1) do j=jsta,jend - do i=ista,iend + do i=1,im if (zint(i,j,lp1) /= spval) then fis(i,j) = zint(i,j,lp1) * grav else @@ -797,7 +795,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) do l=lm,1,-1 do j=jsta,jend - do i=ista,iend + do i=1,im if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then !make sure delz is positive zint(i,j,l)=zint(i,j,l+1)+abs(buf3d(i,j,l)) @@ -812,7 +810,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) do l=lp1,1,-1 do j=jsta,jend - do i=ista,iend + do i=1,im alpint(i,j,l)=log(pint(i,j,l)) end do end do @@ -820,7 +818,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) do l=lm,1,-1 do j=jsta,jend - do i=ista,iend + do i=1,im if(zint(i,j,l+1)/=spval .and. zint(i,j,l)/=spval & .and. pmid(i,j,l)/=spval)then zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & @@ -914,20 +912,20 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !Set REF_10CM as missning since gfs doesn't ouput it do l=1,lm do j=jsta,jend - do i=ista,iend + do i=1,im REF_10CM(i,j,l)=spval enddo enddo enddo VarName='land' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sm) if(debugprint)print*,'sample ',VarName,' =',sm(im/2,(jsta+jend)/2) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j) enddo enddo @@ -935,7 +933,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! sea ice mask VarName = 'icec' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sice) if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa) @@ -949,7 +947,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0 enddo enddo @@ -957,54 +955,54 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! PBL height using nemsio VarName = 'hpbl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pblh) if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa) ! frictional velocity using nemsio VarName='fricv' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ustar) ! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa) ! roughness length using getgb VarName='sfcr' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,z0) ! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa) ! sfc exchange coeff VarName='sfexc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,SFCEXC) ! aerodynamic conductance VarName='acond' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,acond) if(debugprint)print*,'sample ',VarName,' = ',acond(isa,jsa) ! mid day avg albedo VarName='albdo_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgalbedo) if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) do j=jsta,jend - do i=ista,iend + do i=1,im if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 enddo enddo ! surface potential T using getgb VarName='tmpsfc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ths) ! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (ths(i,j) /= spval) then ! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa @@ -1036,12 +1034,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! convective precip in m per physics time step using getgb ! read 3 hour bucket VarName='cpratb_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcprate) ! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001) enddo enddo @@ -1051,11 +1049,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! read continuous bucket VarName='cprat_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcprate_cont) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (avgcprate_cont(i,j) /= spval) avgcprate_cont(i,j) = & avgcprate_cont(i,j) * (dtq2*0.001) enddo @@ -1066,11 +1064,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! precip rate in m per physics time step using getgb VarName='prateb_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgprec) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if(avgprec(i,j) /= spval)avgprec(i,j)=avgprec(i,j)*(dtq2*0.001) enddo enddo @@ -1080,12 +1078,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! prec = avgprec !set avg cprate to inst one to derive other fields VarName='prate_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgprec_cont) ! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (avgprec_cont(i,j) /=spval)avgprec_cont(i,j)=avgprec_cont(i,j) & * (dtq2*0.001) enddo @@ -1094,11 +1092,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample ',VarName,' = ',avgprec_cont(isa,jsa) ! precip rate in m per physics time step VarName='tprcp' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,prec) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (prec(i,j) /= spval) prec(i,j)=prec(i,j)* (dtq2*0.001) & * 1000. / dtp enddo @@ -1106,11 +1104,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! convective precip rate in m per physics time step VarName='cnvprcp' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,cprate) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (cprate(i,j) /= spval) then cprate(i,j) = max(0.,cprate(i,j)) * (dtq2*0.001) & * 1000. / dtp @@ -1153,18 +1151,18 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 2m T using nemsio VarName='tmp2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,tshltr) if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) ! inst snow water eqivalent using nemsio VarName='weasd' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sno) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) == 1.0 .and. sice(i,j)==0.) sno(i,j) = spval enddo enddo @@ -1172,11 +1170,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! ave snow cover VarName='snowc_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,snoavg) ! snow cover is multipled by 100 in SURFCE before writing it out do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j)=spval if(snoavg(i,j)/=spval)snoavg(i,j)=snoavg(i,j)/100. end do @@ -1184,11 +1182,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! snow depth in mm using nemsio VarName='snod' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,si) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency @@ -1203,13 +1201,13 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 2m T using nemsio VarName='tmp2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,tshltr) if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) ! GFS does not have 2m pres, estimate it, also convert t to theta Do j=jsta,jend - do i=ista,iend + Do i=1,im PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta ! if (j == jm/2 .and. mod(i,50) == 0) @@ -1220,7 +1218,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 2m specific humidity using nemsio VarName='spfh2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,qshltr) if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa) @@ -1231,7 +1229,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction !!$omp parallel do private(i,j) ! do j=jsta,jend -! do i=ista,iend +! do i=1,im ! if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 ! enddo ! enddo @@ -1239,12 +1237,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged column cloud fractionusing nemsio VarName='tcdc_aveclm' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgtcdc) ! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01 enddo enddo @@ -1253,7 +1251,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! GFS probably does not use zenith angle !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=ista_2l, iend_2u + do i=1,im Czen(i,j) = spval CZMEAN(i,j) = SPVAL enddo @@ -1261,12 +1259,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! maximum snow albedo in fraction using nemsio VarName='snoalb' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,mxsnal) ! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01 enddo enddo @@ -1275,7 +1273,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! GFS probably does not use sigt4, set it to sig*t^4 !$omp parallel do private(i,j,tlmh) Do j=jsta,jend - do i=ista,iend + Do i=1,im TLMH = T(I,J,LM) * T(I,J,LM) Sigt4(i,j) = 5.67E-8 * TLMH * TLMH End do @@ -1286,7 +1284,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! GFS does not have inst cloud fraction for high, middle, and low cloud !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u + do i=1,im cfrach(i,j) = spval cfracl(i,j) = spval cfracm(i,j) = spval @@ -1295,12 +1293,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! ave high cloud fraction using nemsio VarName='tcdc_avehcl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcfrach) ! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01 enddo enddo @@ -1308,12 +1306,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! ave low cloud fraction using nemsio VarName='tcdc_avelcl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcfracl) ! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01 enddo enddo @@ -1321,12 +1319,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! ave middle cloud fraction using nemsio VarName='tcdc_avemcl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcfracm) ! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01 enddo enddo @@ -1334,12 +1332,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst convective cloud fraction using nemsio VarName='tcdccnvcl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,cnvcfr) ! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01 enddo enddo @@ -1347,11 +1345,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! slope type using nemsio VarName='sltyp' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,buf) !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=ista_2l,iend_2u + do i=1,im if (buf(i,j) < spval) then islope(i,j) = nint(buf(i,j)) else @@ -1363,11 +1361,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! plant canopy sfc wtr in m VarName='cnwat' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,cmc) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001 if (sm(i,j) /= 0.0) cmc(i,j) = spval enddo @@ -1376,18 +1374,18 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u + do i=1,im grnflx(i,j) = spval ! GFS does not have inst ground heat flux enddo enddo ! frozen precip fraction using nemsio VarName='cpofp' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sr) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if(sr(i,j) /= spval) then !set range within (0,1) sr(i,j)=min(1.,max(0.,sr(i,j))) @@ -1397,22 +1395,22 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! sea ice skin temperature VarName='tisfc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ti) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sice(i,j) == spval .or. sice(i,j) == 0.) ti(i,j)=spval enddo enddo ! vegetation fraction in fraction. using nemsio VarName='veg' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,vegfrc) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (vegfrc(i,j) /= spval) then vegfrc(i,j) = vegfrc(i,j) * 0.01 else @@ -1423,7 +1421,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) vegfrc(i,j) = spval enddo enddo @@ -1438,48 +1436,48 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! liquid volumetric soil mpisture in fraction using nemsio VarName='soill1' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sh2o(1,jsta_2l,1)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) sh2o(i,j,1) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1) VarName='soill2' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sh2o(1,jsta_2l,2)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) sh2o(i,j,2) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2) VarName='soill3' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sh2o(1,jsta_2l,3)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) sh2o(i,j,3) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3) VarName='soill4' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sh2o(1,jsta_2l,4)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) sh2o(i,j,4) = spval enddo enddo @@ -1487,48 +1485,48 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! volumetric soil moisture using nemsio VarName='soilw1' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smc(1,jsta_2l,1)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) smc(i,j,1) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1) VarName='soilw2' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smc(1,jsta_2l,2)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) smc(i,j,2) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2) VarName='soilw3' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smc(1,jsta_2l,3)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) smc(i,j,3) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3) VarName='soilw4' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smc(1,jsta_2l,4)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) smc(i,j,4) = spval enddo enddo @@ -1536,12 +1534,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! soil temperature using nemsio VarName='soilt1' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,stc(1,jsta_2l,1)) ! mask open water areas, combine with sea ice tmp !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,1) = spval !if (sm(i,j) /= 0.0) stc(i,j,1) = spval enddo @@ -1549,12 +1547,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1) VarName='soilt2' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,stc(1,jsta_2l,2)) ! mask open water areas, combine with sea ice tmp !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,2) = spval !if (sm(i,j) /= 0.0) stc(i,j,2) = spval enddo @@ -1562,12 +1560,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2) VarName='soilt3' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,stc(1,jsta_2l,3)) ! mask open water areas, combine with sea ice tmp !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,3) = spval !if (sm(i,j) /= 0.0) stc(i,j,3) = spval enddo @@ -1575,12 +1573,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3) VarName='soilt4' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,stc(1,jsta_2l,4)) ! mask open water areas, combine with sea ice tmp !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,4) = spval !if (sm(i,j) /= 0.0) stc(i,j,4) = spval enddo @@ -1589,7 +1587,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 ncfrcv(i,j) = 1.0 acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 @@ -1603,27 +1601,27 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged incoming sfc longwave VarName='dlwrf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwin) ! inst incoming sfc longwave VarName='dlwrf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,rlwin) ! time averaged outgoing sfc longwave VarName='ulwrf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwout) ! inst outgoing sfc longwave VarName='ulwrf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,radot) ! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j) enddo enddo @@ -1631,7 +1629,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged outgoing model top longwave using gfsio VarName='ulwrf_avetoa' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwtoa) ! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa) @@ -1641,40 +1639,40 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged incoming sfc shortwave VarName='dswrf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswin) ! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa) ! inst incoming sfc shortwave VarName='dswrf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,rswin) ! inst incoming clear sky sfc shortwave VarName='csdlf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,rswinc) ! time averaged incoming sfc uv-b using getgb VarName='duvb_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,auvbin) ! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa) ! time averaged incoming sfc clear sky uv-b using getgb VarName='cduvb_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,auvbinc) ! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa) ! time averaged outgoing sfc shortwave using gfsio VarName='uswrf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswout) ! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j) enddo enddo @@ -1682,30 +1680,30 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst outgoing sfc shortwave using gfsio VarName='uswrf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,rswout) ! time averaged model top incoming shortwave VarName='dswrf_avetoa' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswintoa) ! if(debugprint)print*,'sample l',VarName,' = ',1,aswintoa(isa,jsa) ! time averaged model top outgoing shortwave VarName='uswrf_avetoa' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswtoa) ! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa) ! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux ! has reversed sign convention using gfsio VarName='shtfl_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sfcshx) ! where (sfcshx /= spval)sfcshx=-sfcshx !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j) enddo enddo @@ -1713,11 +1711,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst surface sensible heat flux VarName='shtfl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,twbs) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (twbs(i,j) /= spval) twbs(i,j) = -twbs(i,j) enddo enddo @@ -1729,12 +1727,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged surface latent heat flux, multiplied by -1 because wrf model flux ! has reversed sign vonvention using gfsio VarName='lhtfl_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sfclhx) ! where (sfclhx /= spval)sfclhx=-sfclhx !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j) enddo enddo @@ -1742,11 +1740,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst surface latent heat flux VarName='lhtfl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,qwbs) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (qwbs(i,j) /= spval) qwbs(i,j) = -qwbs(i,j) enddo enddo @@ -1755,39 +1753,39 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst aod550 optical depth if(rdaod) then VarName='aod550' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aod550) VarName='du_aod550' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,du_aod550) VarName='ss_aod550' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ss_aod550) VarName='su_aod550' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,su_aod550) VarName='oc_aod550' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,oc_aod550) VarName='bc_aod550' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,bc_aod550) endif !end if rdaod ! time averaged ground heat flux using nemsio VarName='gflux_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,subshx) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval enddo enddo @@ -1795,25 +1793,25 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst ground heat flux using nemsio VarName='gflux' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,grnflx) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval enddo enddo ! time averaged zonal momentum flux using gfsio VarName='uflx_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sfcux) ! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa) ! time averaged meridional momentum flux using nemsio VarName='vflx_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sfcvx) ! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa) @@ -1833,31 +1831,31 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u + do i=1,im sfcuvx(i,j) = spval ! GFS does not use total momentum flux enddo enddo ! time averaged zonal gravity wave stress using nemsio VarName='u-gwd_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,gtaux) ! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa) ! time averaged meridional gravity wave stress using getgb VarName='v-gwd_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,gtauy) ! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa) ! time averaged accumulated potential evaporation VarName='pevpr_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgpotevp) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval enddo enddo @@ -1865,12 +1863,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst potential evaporation VarName='pevpr' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,potevp) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval enddo enddo @@ -1878,7 +1876,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) do l=1,lm !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u + do i=1,im ! GFS does not have temperature tendency due to long wave radiation rlwtt(i,j,l) = spval ! GFS does not have temperature tendency due to short wave radiation @@ -1899,11 +1897,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 10 m u using nemsio VarName='ugrd10m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,u10) do j=jsta,jend - do i=ista,iend + do i=1,im u10h(i,j)=u10(i,j) end do end do @@ -1911,11 +1909,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 10 m v using gfsio VarName='vgrd10m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,v10) do j=jsta,jend - do i=ista,iend + do i=1,im v10h(i,j)=v10(i,j) end do end do @@ -1923,7 +1921,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon VarName='vtype' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,buf) ! where (buf /= spval) ! ivgtyp=nint(buf) @@ -1932,7 +1930,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! end where !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=ista_2l,iend_2u + do i=1,im if (buf(i,j) < spval) then ivgtyp(i,j) = nint(buf(i,j)) else @@ -1944,11 +1942,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! soil type, it's in GFS surface file, hopefully will merge into gfsio soon VarName='sotyp' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,buf) !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=ista_2l,iend_2u + do i=1,im if (buf(i,j) < spval) then isltyp(i,j) = nint(buf(i,j)) else @@ -1960,7 +1958,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u + do i=1,im smstav(i,j) = spval ! GFS does not have soil moisture availability ! smstot(i,j) = spval ! GFS does not have total soil moisture sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation @@ -1976,7 +1974,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) do l=1,lm !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u + do i=1,im EL_PBL(i,j,l) = spval ! GFS does not have mixing length exch_h(i,j,l) = spval ! GFS does not output exchange coefficient enddo @@ -1991,19 +1989,19 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! l=1 ! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa) VarName='prescnvclt' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ptop) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im htop(i,j) = spval if(ptop(i,j) <= 0.0) ptop(i,j) = spval enddo enddo do j=jsta,jend - do i=ista,iend + do i=1,im if(ptop(i,j) < spval)then do l=1,lm if(ptop(i,j) <= pmid(i,j,l))then @@ -2020,18 +2018,18 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, ! will need to modify CLDRAD.f to use pressure directly instead of index VarName='prescnvclb' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pbot) ! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im hbot(i,j) = spval if(pbot(i,j) <= 0.0) pbot(i,j) = spval enddo enddo do j=jsta,jend - do i=ista,iend + do i=1,im ! if(.not.lb(i,j))print*,'false bitmask for pbot at ' ! + ,i,j,pbot(i,j) if(pbot(i,j) < spval)then @@ -2049,85 +2047,85 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample hbot = ',hbot(isa,jsa) ! retrieve time averaged low cloud top pressure using nemsio VarName='pres_avelct' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ptopl) ! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa) ! retrieve time averaged low cloud bottom pressure using nemsio VarName='pres_avelcb' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pbotl) ! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa) ! retrieve time averaged low cloud top temperature using nemsio VarName='tmp_avelct' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,Ttopl) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa) ! retrieve time averaged middle cloud top pressure using nemsio VarName='pres_avemct' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ptopm) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa) ! retrieve time averaged middle cloud bottom pressure using nemsio VarName='pres_avemcb' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pbotm) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa) ! retrieve time averaged middle cloud top temperature using nemsio VarName='tmp_avemct' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,Ttopm) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa) ! retrieve time averaged high cloud top pressure using nemsio ********* VarName='pres_avehct' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ptoph) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa) ! retrieve time averaged high cloud bottom pressure using nemsio VarName='pres_avehcb' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pboth) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa) ! retrieve time averaged high cloud top temperature using nemsio VarName='tmp_avehct' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,Ttoph) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa) ! retrieve boundary layer cloud cover using nemsio VarName='tcdc_avebndcl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pblcfr) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa) ! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=ista_2l,iend_2u + do i=1,im if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01 enddo enddo ! retrieve cloud work function VarName='cwork_aveclm' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,cldwork) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa) ! accumulated total (base+surface) runoff VarName='watr_acc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,runoff) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) runoff(i,j) = spval enddo enddo @@ -2135,12 +2133,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve shelter max temperature using nemsio VarName='tmax_max2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,maxtshltr) ! retrieve shelter min temperature using nemsio VarName='tmin_min2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,mintshltr) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & ! 1,mintshltr(im/2,(jsta+jend)/2) @@ -2159,7 +2157,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u + do i=1,im MAXRHSHLTR(i,j) = SPVAL MINRHSHLTR(i,j) = SPVAL enddo @@ -2167,18 +2165,18 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve ice thickness using nemsio VarName='icetk' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,dzice) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa) ! retrieve wilting point using nemsio VarName='wilt' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smcwlt) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) smcwlt(i,j) = spval enddo enddo @@ -2186,17 +2184,17 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve sunshine duration using nemsio VarName='sunsd_acc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,suntime) ! retrieve field capacity using nemsio VarName='fldcp' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,fieldcapa) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) fieldcapa(i,j) = spval enddo enddo @@ -2204,147 +2202,147 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve time averaged surface visible beam downward solar flux VarName='vbdsf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avisbeamswin) l=1 ! retrieve time averaged surface visible diffuse downward solar flux VarName='vddsf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avisdiffswin) ! retrieve time averaged surface near IR beam downward solar flux VarName='nbdsf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,airbeamswin) ! retrieve time averaged surface near IR diffuse downward solar flux VarName='nddsf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,airdiffswin) ! retrieve time averaged surface clear sky outgoing LW VarName='csulf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwoutc) ! retrieve time averaged TOA clear sky outgoing LW VarName='csulftoa' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwtoac) ! retrieve time averaged surface clear sky outgoing SW VarName='csusf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswoutc) ! retrieve time averaged TOA clear sky outgoing LW VarName='csusftoa' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswtoac) ! retrieve time averaged surface clear sky incoming LW VarName='csdlf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwinc) ! retrieve time averaged surface clear sky incoming SW VarName='csdsf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswinc) ! retrieve shelter max specific humidity using nemsio VarName='spfhmax_max2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,maxqshltr) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', ! 1,maxqshltr(isa,jsa) ! retrieve shelter min temperature using nemsio VarName='spfhmin_min2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,minqshltr) ! retrieve storm runoff using nemsio VarName='ssrun_acc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,SSROFF) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) ssroff(i,j) = spval enddo enddo ! retrieve direct soil evaporation VarName='evbs_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgedir) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) avgedir(i,j) = spval enddo enddo ! retrieve CANOPY WATER EVAP VarName='evcw_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgecan) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) avgecan(i,j) = spval enddo enddo ! retrieve PLANT TRANSPIRATION VarName='trans_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgetrans) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) avgetrans(i,j) = spval enddo enddo ! retrieve snow sublimation VarName='sbsno_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgesnow) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval enddo enddo ! retrive total soil moisture VarName='soilm' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smstot) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) smstot(i,j) = spval enddo enddo ! retrieve snow phase change heat flux VarName='snohf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,snopcx) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im if (sm(i,j) /= 0.0) snopcx(i,j) = spval enddo enddo @@ -2353,7 +2351,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im HTOPD(i,j) = SPVAL HBOTD(i,j) = SPVAL HTOPS(i,j) = SPVAL @@ -2500,7 +2498,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) RETURN END - subroutine read_netcdf_3d_para(ncid,im,jm,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + subroutine read_netcdf_3d_para(ncid,im,jm,jsta,jsta_2l,jend,jend_2u, & spval,varname,buf,lm) use netcdf @@ -2510,9 +2508,8 @@ subroutine read_netcdf_3d_para(ncid,im,jm,ista,ista_2l,iend,iend_2u,jsta,jsta_2l character(len=20),intent(in) :: varname real,intent(in) :: spval integer,intent(in) :: ncid,im,jm,lm,jsta_2l,jend_2u,jsta,jend - integer,intent(in) :: ista_2l,iend_2u,ista,iend - real,intent(out) :: buf(ista_2l:iend_2u,jsta_2l:jend_2u,lm) - integer :: varid,iret,ii,jj,i,j,l,kk + real,intent(out) :: buf(im,jsta_2l:jend_2u,lm) + integer :: varid,iret,jj,i,j,l,kk integer :: start(3), count(3), stride(3) iret = nf90_inq_varid(ncid,trim(varname),varid) @@ -2521,26 +2518,21 @@ subroutine read_netcdf_3d_para(ncid,im,jm,ista,ista_2l,iend,iend_2u,jsta,jsta_2l !$omp parallel do private(i,j,l) do l=1,lm do j=jsta,jend - do i=ista,iend + do i=1,im buf(i,j,l)=spval enddo enddo enddo else -! start = (/1,jsta,1/) -! jj=jend-jsta+1 -! count = (/im,jj,lm/) -! iret = nf90_get_var(ncid,varid,buf(1:im,jsta:jend,1:lm),start=start,count=count) - start = (/ista,jsta,1/) + start = (/1,jsta,1/) jj=jend-jsta+1 - ii=iend-ista+1 - count = (/ii,jj,lm/) - iret = nf90_get_var(ncid,varid,buf(ista:iend,jsta:jend,1:lm),start=start,count=count) + count = (/im,jj,lm/) + iret = nf90_get_var(ncid,varid,buf(1:im,jsta:jend,1:lm),start=start,count=count) endif end subroutine read_netcdf_3d_para - subroutine read_netcdf_2d_para(ncid,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + subroutine read_netcdf_2d_para(ncid,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,buf) use netcdf @@ -2549,10 +2541,9 @@ subroutine read_netcdf_2d_para(ncid,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend, character(len=20),intent(in) :: VarName real,intent(in) :: spval - integer,intent(in) :: ncid,jsta_2l,jend_2u,jsta,jend - integer,intent(in) :: ista_2l,iend_2u,ista,iend - real,intent(out) :: buf(ista_2l:iend_2u,jsta_2l:jend_2u) - integer :: varid,iret,ii,jj,i,j + integer,intent(in) :: ncid,im,jsta_2l,jend_2u,jsta,jend + real,intent(out) :: buf(im,jsta_2l:jend_2u) + integer :: varid,iret,jj,i,j integer :: start(2), count(2) iret = nf90_inq_varid(ncid,trim(varname),varid) @@ -2560,20 +2551,15 @@ subroutine read_netcdf_2d_para(ncid,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend, print*,VarName," not found -Assigned missing values" !$omp parallel do private(i,j) do j=jsta,jend - do i=ista,iend + do i=1,im buf(i,j)=spval enddo enddo else -! start = (/1,jsta/) -! jj=jend-jsta+1 -! count = (/im,jj/) -! iret = nf90_get_var(ncid,varid,buf(:,jsta),start=start,count=count) - start = (/ista,jsta/) + start = (/1,jsta/) jj=jend-jsta+1 - ii=iend-ista+1 - count = (/ii,jj/) - iret = nf90_get_var(ncid,varid,buf(ista:iend,jsta:jend),start=start,count=count) + count = (/im,jj/) + iret = nf90_get_var(ncid,varid,buf(:,jsta),start=start,count=count) endif end subroutine read_netcdf_2d_para diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 77b57b04a..97a83c6d9 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -102,7 +102,7 @@ SUBROUTINE MPI_FIRST() integer numx !number of subdomain in x direction ! isumm=0 - numx=1 + numx=2 if ( me == 0 ) then ! print *, ' NUM_PROCS = ',num_procs diff --git a/sorc/ncep_post.fd/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f index d6caabadf..92c7573b6 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -141,6 +141,7 @@ 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, & + 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, & @@ -841,11 +842,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 47bf52965..947702e1a 100644 --- a/sorc/ncep_post.fd/grib2_module.f +++ b/sorc/ncep_post.fd/grib2_module.f @@ -196,7 +196,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 ! @@ -214,10 +214,12 @@ 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(:,:) real,allocatable :: datafldtmp(:) + real,allocatable :: datafldtmp2(:,:,:) logical, parameter :: debugprint = .false. ! character(1), dimension(:), allocatable :: cgrib @@ -252,6 +254,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) @@ -268,7 +276,8 @@ 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) ) @@ -338,39 +347,51 @@ 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(n1.0E6 .or. pint(1,jsta_2l,lp1)<50000.) & ! print*,'bad psfc ',i,j,pint(i,j,lp1) end do @@ -752,14 +755,14 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(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 pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) enddo enddo @@ -770,7 +773,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !compute pmid from averaged two layer pint do l=lm,1,-1 do j=jsta,jend - do i=1,im + do i=ista,iend pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) enddo enddo @@ -780,11 +783,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! dong set missing value for zint ! zint=spval VarName='hgtsfc' - call read_netcdf_2d_para(ncid3d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,zint(1,jsta_2l,lp1)) + call read_netcdf_2d_para(ncid3d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,zint(ista_2l,jsta_2l,lp1)) if(debugprint)print*,'sample ',VarName,' =',zint(isa,jsa,lp1) do j=jsta,jend - do i=1,im + do i=ista,iend if (zint(i,j,lp1) /= spval) then fis(i,j) = zint(i,j,lp1) * grav else @@ -795,7 +798,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) do l=lm,1,-1 do j=jsta,jend - do i=1,im + do i=ista,iend if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then !make sure delz is positive zint(i,j,l)=zint(i,j,l+1)+abs(buf3d(i,j,l)) @@ -810,7 +813,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) do l=lp1,1,-1 do j=jsta,jend - do i=1,im + do i=ista,iend alpint(i,j,l)=log(pint(i,j,l)) end do end do @@ -818,7 +821,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) do l=lm,1,-1 do j=jsta,jend - do i=1,im + do i=ista,iend if(zint(i,j,l+1)/=spval .and. zint(i,j,l)/=spval & .and. pmid(i,j,l)/=spval)then zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & @@ -912,20 +915,20 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !Set REF_10CM as missning since gfs doesn't ouput it do l=1,lm do j=jsta,jend - do i=1,im + do i=ista,iend REF_10CM(i,j,l)=spval enddo enddo enddo VarName='land' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sm) if(debugprint)print*,'sample ',VarName,' =',sm(im/2,(jsta+jend)/2) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j) enddo enddo @@ -933,7 +936,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! sea ice mask VarName = 'icec' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sice) if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa) @@ -947,7 +950,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0 enddo enddo @@ -955,54 +958,54 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! PBL height using nemsio VarName = 'hpbl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pblh) if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa) ! frictional velocity using nemsio VarName='fricv' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ustar) ! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa) ! roughness length using getgb VarName='sfcr' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,z0) ! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa) ! sfc exchange coeff VarName='sfexc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,SFCEXC) ! aerodynamic conductance VarName='acond' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,acond) if(debugprint)print*,'sample ',VarName,' = ',acond(isa,jsa) ! mid day avg albedo VarName='albdo_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgalbedo) if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 enddo enddo ! surface potential T using getgb VarName='tmpsfc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ths) ! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (ths(i,j) /= spval) then ! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa @@ -1034,12 +1037,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! convective precip in m per physics time step using getgb ! read 3 hour bucket VarName='cpratb_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcprate) ! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001) enddo enddo @@ -1049,11 +1052,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! read continuous bucket VarName='cprat_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcprate_cont) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgcprate_cont(i,j) /= spval) avgcprate_cont(i,j) = & avgcprate_cont(i,j) * (dtq2*0.001) enddo @@ -1064,11 +1067,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! precip rate in m per physics time step using getgb VarName='prateb_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgprec) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if(avgprec(i,j) /= spval)avgprec(i,j)=avgprec(i,j)*(dtq2*0.001) enddo enddo @@ -1078,12 +1081,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! prec = avgprec !set avg cprate to inst one to derive other fields VarName='prate_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgprec_cont) ! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgprec_cont(i,j) /=spval)avgprec_cont(i,j)=avgprec_cont(i,j) & * (dtq2*0.001) enddo @@ -1092,11 +1095,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample ',VarName,' = ',avgprec_cont(isa,jsa) ! precip rate in m per physics time step VarName='tprcp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,prec) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (prec(i,j) /= spval) prec(i,j)=prec(i,j)* (dtq2*0.001) & * 1000. / dtp enddo @@ -1104,11 +1107,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! convective precip rate in m per physics time step VarName='cnvprcp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,cprate) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (cprate(i,j) /= spval) then cprate(i,j) = max(0.,cprate(i,j)) * (dtq2*0.001) & * 1000. / dtp @@ -1151,18 +1154,18 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 2m T using nemsio VarName='tmp2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,tshltr) if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) ! inst snow water eqivalent using nemsio VarName='weasd' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sno) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j)==0.) sno(i,j) = spval enddo enddo @@ -1170,11 +1173,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! ave snow cover VarName='snowc_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,snoavg) ! snow cover is multipled by 100 in SURFCE before writing it out do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j)=spval if(snoavg(i,j)/=spval)snoavg(i,j)=snoavg(i,j)/100. end do @@ -1182,11 +1185,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! snow depth in mm using nemsio VarName='snod' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,si) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency @@ -1201,13 +1204,13 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 2m T using nemsio VarName='tmp2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,tshltr) if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) ! GFS does not have 2m pres, estimate it, also convert t to theta Do j=jsta,jend - Do i=1,im + do i=ista,iend PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta ! if (j == jm/2 .and. mod(i,50) == 0) @@ -1218,7 +1221,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 2m specific humidity using nemsio VarName='spfh2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,qshltr) if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa) @@ -1229,7 +1232,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction !!$omp parallel do private(i,j) ! do j=jsta,jend -! do i=1,im +! do i=ista,iend ! if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 ! enddo ! enddo @@ -1237,12 +1240,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged column cloud fractionusing nemsio VarName='tcdc_aveclm' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgtcdc) ! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01 enddo enddo @@ -1251,7 +1254,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! GFS probably does not use zenith angle !$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 enddo @@ -1259,12 +1262,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! maximum snow albedo in fraction using nemsio VarName='snoalb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,mxsnal) ! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01 enddo enddo @@ -1273,7 +1276,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! GFS probably does not use sigt4, set it to sig*t^4 !$omp parallel do private(i,j,tlmh) Do j=jsta,jend - Do i=1,im + do i=ista,iend TLMH = T(I,J,LM) * T(I,J,LM) Sigt4(i,j) = 5.67E-8 * TLMH * TLMH End do @@ -1284,7 +1287,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! GFS does not have inst cloud fraction for high, middle, and low cloud !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u cfrach(i,j) = spval cfracl(i,j) = spval cfracm(i,j) = spval @@ -1293,12 +1296,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! ave high cloud fraction using nemsio VarName='tcdc_avehcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcfrach) ! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01 enddo enddo @@ -1306,12 +1309,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! ave low cloud fraction using nemsio VarName='tcdc_avelcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcfracl) ! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01 enddo enddo @@ -1319,12 +1322,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! ave middle cloud fraction using nemsio VarName='tcdc_avemcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgcfracm) ! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01 enddo enddo @@ -1332,12 +1335,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst convective cloud fraction using nemsio VarName='tcdccnvcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,cnvcfr) ! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01 enddo enddo @@ -1345,11 +1348,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! slope type using nemsio VarName='sltyp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,buf) !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=1,im + do i=ista_2l,iend_2u if (buf(i,j) < spval) then islope(i,j) = nint(buf(i,j)) else @@ -1361,11 +1364,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! plant canopy sfc wtr in m VarName='cnwat' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,cmc) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001 if (sm(i,j) /= 0.0) cmc(i,j) = spval enddo @@ -1374,18 +1377,18 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u grnflx(i,j) = spval ! GFS does not have inst ground heat flux enddo enddo ! frozen precip fraction using nemsio VarName='cpofp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sr) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if(sr(i,j) /= spval) then !set range within (0,1) sr(i,j)=min(1.,max(0.,sr(i,j))) @@ -1395,22 +1398,22 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! sea ice skin temperature VarName='tisfc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ti) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sice(i,j) == spval .or. sice(i,j) == 0.) ti(i,j)=spval enddo enddo ! vegetation fraction in fraction. using nemsio VarName='veg' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,vegfrc) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (vegfrc(i,j) /= spval) then vegfrc(i,j) = vegfrc(i,j) * 0.01 else @@ -1421,7 +1424,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) vegfrc(i,j) = spval enddo enddo @@ -1436,48 +1439,48 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! liquid volumetric soil mpisture in fraction using nemsio VarName='soill1' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sh2o(1,jsta_2l,1)) + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,sh2o(ista_2l,jsta_2l,1)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) sh2o(i,j,1) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1) VarName='soill2' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sh2o(1,jsta_2l,2)) + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,sh2o(ista_2l,jsta_2l,2)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) sh2o(i,j,2) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2) VarName='soill3' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sh2o(1,jsta_2l,3)) + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,sh2o(ista_2l,jsta_2l,3)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) sh2o(i,j,3) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3) VarName='soill4' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sh2o(1,jsta_2l,4)) + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,sh2o(ista_2l,jsta_2l,4)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) sh2o(i,j,4) = spval enddo enddo @@ -1485,48 +1488,48 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! volumetric soil moisture using nemsio VarName='soilw1' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smc(1,jsta_2l,1)) + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,smc(ista_2l,jsta_2l,1)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) smc(i,j,1) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1) VarName='soilw2' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smc(1,jsta_2l,2)) + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,smc(ista_2l,jsta_2l,2)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) smc(i,j,2) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2) VarName='soilw3' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smc(1,jsta_2l,3)) + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,smc(ista_2l,jsta_2l,3)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) smc(i,j,3) = spval enddo enddo if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3) VarName='soilw4' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smc(1,jsta_2l,4)) + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,smc(ista_2l,jsta_2l,4)) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) smc(i,j,4) = spval enddo enddo @@ -1534,12 +1537,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! soil temperature using nemsio VarName='soilt1' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,stc(1,jsta_2l,1)) + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,stc(ista_2l,jsta_2l,1)) ! mask open water areas, combine with sea ice tmp !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,1) = spval !if (sm(i,j) /= 0.0) stc(i,j,1) = spval enddo @@ -1547,12 +1550,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1) VarName='soilt2' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,stc(1,jsta_2l,2)) + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,stc(ista_2l,jsta_2l,2)) ! mask open water areas, combine with sea ice tmp !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,2) = spval !if (sm(i,j) /= 0.0) stc(i,j,2) = spval enddo @@ -1560,12 +1563,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2) VarName='soilt3' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,stc(1,jsta_2l,3)) + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,stc(ista_2l,jsta_2l,3)) ! mask open water areas, combine with sea ice tmp !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,3) = spval !if (sm(i,j) /= 0.0) stc(i,j,3) = spval enddo @@ -1573,12 +1576,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3) VarName='soilt4' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,stc(1,jsta_2l,4)) + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & + spval,VarName,stc(ista_2l,jsta_2l,4)) ! mask open water areas, combine with sea ice tmp !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,4) = spval !if (sm(i,j) /= 0.0) stc(i,j,4) = spval enddo @@ -1587,7 +1590,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 ncfrcv(i,j) = 1.0 acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 @@ -1601,27 +1604,27 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged incoming sfc longwave VarName='dlwrf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwin) ! inst incoming sfc longwave VarName='dlwrf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,rlwin) ! time averaged outgoing sfc longwave VarName='ulwrf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwout) ! inst outgoing sfc longwave VarName='ulwrf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,radot) ! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j) enddo enddo @@ -1629,7 +1632,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged outgoing model top longwave using gfsio VarName='ulwrf_avetoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwtoa) ! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa) @@ -1639,40 +1642,40 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged incoming sfc shortwave VarName='dswrf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswin) ! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa) ! inst incoming sfc shortwave VarName='dswrf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,rswin) ! inst incoming clear sky sfc shortwave VarName='csdlf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,rswinc) ! time averaged incoming sfc uv-b using getgb VarName='duvb_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,auvbin) ! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa) ! time averaged incoming sfc clear sky uv-b using getgb VarName='cduvb_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,auvbinc) ! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa) ! time averaged outgoing sfc shortwave using gfsio VarName='uswrf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswout) ! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j) enddo enddo @@ -1680,30 +1683,30 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst outgoing sfc shortwave using gfsio VarName='uswrf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,rswout) ! time averaged model top incoming shortwave VarName='dswrf_avetoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswintoa) ! if(debugprint)print*,'sample l',VarName,' = ',1,aswintoa(isa,jsa) ! time averaged model top outgoing shortwave VarName='uswrf_avetoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswtoa) ! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa) ! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux ! has reversed sign convention using gfsio VarName='shtfl_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sfcshx) ! where (sfcshx /= spval)sfcshx=-sfcshx !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j) enddo enddo @@ -1711,11 +1714,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst surface sensible heat flux VarName='shtfl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,twbs) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (twbs(i,j) /= spval) twbs(i,j) = -twbs(i,j) enddo enddo @@ -1727,12 +1730,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! time averaged surface latent heat flux, multiplied by -1 because wrf model flux ! has reversed sign vonvention using gfsio VarName='lhtfl_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sfclhx) ! where (sfclhx /= spval)sfclhx=-sfclhx !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j) enddo enddo @@ -1740,11 +1743,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst surface latent heat flux VarName='lhtfl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,qwbs) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (qwbs(i,j) /= spval) qwbs(i,j) = -qwbs(i,j) enddo enddo @@ -1753,39 +1756,39 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst aod550 optical depth if(rdaod) then VarName='aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aod550) VarName='du_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,du_aod550) VarName='ss_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ss_aod550) VarName='su_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,su_aod550) VarName='oc_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,oc_aod550) VarName='bc_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,bc_aod550) endif !end if rdaod ! time averaged ground heat flux using nemsio VarName='gflux_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,subshx) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval enddo enddo @@ -1793,25 +1796,25 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst ground heat flux using nemsio VarName='gflux' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,grnflx) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval enddo enddo ! time averaged zonal momentum flux using gfsio VarName='uflx_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sfcux) ! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa) ! time averaged meridional momentum flux using nemsio VarName='vflx_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sfcvx) ! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa) @@ -1831,31 +1834,31 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u sfcuvx(i,j) = spval ! GFS does not use total momentum flux enddo enddo ! time averaged zonal gravity wave stress using nemsio VarName='u-gwd_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,gtaux) ! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa) ! time averaged meridional gravity wave stress using getgb VarName='v-gwd_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,gtauy) ! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa) ! time averaged accumulated potential evaporation VarName='pevpr_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgpotevp) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval enddo enddo @@ -1863,12 +1866,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! inst potential evaporation VarName='pevpr' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,potevp) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval enddo enddo @@ -1876,7 +1879,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) 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 ! GFS does not have temperature tendency due to long wave radiation rlwtt(i,j,l) = spval ! GFS does not have temperature tendency due to short wave radiation @@ -1897,11 +1900,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 10 m u using nemsio VarName='ugrd10m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,u10) do j=jsta,jend - do i=1,im + do i=ista,iend u10h(i,j)=u10(i,j) end do end do @@ -1909,11 +1912,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! 10 m v using gfsio VarName='vgrd10m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,v10) do j=jsta,jend - do i=1,im + do i=ista,iend v10h(i,j)=v10(i,j) end do end do @@ -1921,7 +1924,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon VarName='vtype' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,buf) ! where (buf /= spval) ! ivgtyp=nint(buf) @@ -1930,7 +1933,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! end where !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=1,im + do i=ista_2l,iend_2u if (buf(i,j) < spval) then ivgtyp(i,j) = nint(buf(i,j)) else @@ -1942,11 +1945,11 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! soil type, it's in GFS surface file, hopefully will merge into gfsio soon VarName='sotyp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,buf) !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=1,im + do i=ista_2l,iend_2u if (buf(i,j) < spval) then isltyp(i,j) = nint(buf(i,j)) else @@ -1958,7 +1961,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u smstav(i,j) = spval ! GFS does not have soil moisture availability ! smstot(i,j) = spval ! GFS does not have total soil moisture sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation @@ -1974,7 +1977,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) 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 EL_PBL(i,j,l) = spval ! GFS does not have mixing length exch_h(i,j,l) = spval ! GFS does not output exchange coefficient enddo @@ -1989,19 +1992,19 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! l=1 ! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa) VarName='prescnvclt' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ptop) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend htop(i,j) = spval if(ptop(i,j) <= 0.0) ptop(i,j) = spval enddo enddo do j=jsta,jend - do i=1,im + do i=ista,iend if(ptop(i,j) < spval)then do l=1,lm if(ptop(i,j) <= pmid(i,j,l))then @@ -2018,18 +2021,18 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, ! will need to modify CLDRAD.f to use pressure directly instead of index VarName='prescnvclb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pbot) ! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend hbot(i,j) = spval if(pbot(i,j) <= 0.0) pbot(i,j) = spval enddo enddo do j=jsta,jend - do i=1,im + do i=ista,iend ! if(.not.lb(i,j))print*,'false bitmask for pbot at ' ! + ,i,j,pbot(i,j) if(pbot(i,j) < spval)then @@ -2047,85 +2050,85 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) if(debugprint)print*,'sample hbot = ',hbot(isa,jsa) ! retrieve time averaged low cloud top pressure using nemsio VarName='pres_avelct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ptopl) ! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa) ! retrieve time averaged low cloud bottom pressure using nemsio VarName='pres_avelcb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pbotl) ! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa) ! retrieve time averaged low cloud top temperature using nemsio VarName='tmp_avelct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,Ttopl) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa) ! retrieve time averaged middle cloud top pressure using nemsio VarName='pres_avemct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ptopm) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa) ! retrieve time averaged middle cloud bottom pressure using nemsio VarName='pres_avemcb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pbotm) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa) ! retrieve time averaged middle cloud top temperature using nemsio VarName='tmp_avemct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,Ttopm) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa) ! retrieve time averaged high cloud top pressure using nemsio ********* VarName='pres_avehct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,ptoph) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa) ! retrieve time averaged high cloud bottom pressure using nemsio VarName='pres_avehcb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pboth) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa) ! retrieve time averaged high cloud top temperature using nemsio VarName='tmp_avehct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,Ttoph) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa) ! retrieve boundary layer cloud cover using nemsio VarName='tcdc_avebndcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pblcfr) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa) ! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=1,im + do i=ista_2l,iend_2u if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01 enddo enddo ! retrieve cloud work function VarName='cwork_aveclm' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,cldwork) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa) ! accumulated total (base+surface) runoff VarName='watr_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,runoff) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) runoff(i,j) = spval enddo enddo @@ -2133,12 +2136,12 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve shelter max temperature using nemsio VarName='tmax_max2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,maxtshltr) ! retrieve shelter min temperature using nemsio VarName='tmin_min2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,mintshltr) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & ! 1,mintshltr(im/2,(jsta+jend)/2) @@ -2157,7 +2160,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u MAXRHSHLTR(i,j) = SPVAL MINRHSHLTR(i,j) = SPVAL enddo @@ -2165,18 +2168,18 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve ice thickness using nemsio VarName='icetk' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,dzice) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa) ! retrieve wilting point using nemsio VarName='wilt' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smcwlt) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) smcwlt(i,j) = spval enddo enddo @@ -2184,17 +2187,17 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve sunshine duration using nemsio VarName='sunsd_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,suntime) ! retrieve field capacity using nemsio VarName='fldcp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,fieldcapa) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) fieldcapa(i,j) = spval enddo enddo @@ -2202,147 +2205,147 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve time averaged surface visible beam downward solar flux VarName='vbdsf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avisbeamswin) l=1 ! retrieve time averaged surface visible diffuse downward solar flux VarName='vddsf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avisdiffswin) ! retrieve time averaged surface near IR beam downward solar flux VarName='nbdsf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,airbeamswin) ! retrieve time averaged surface near IR diffuse downward solar flux VarName='nddsf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,airdiffswin) ! retrieve time averaged surface clear sky outgoing LW VarName='csulf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwoutc) ! retrieve time averaged TOA clear sky outgoing LW VarName='csulftoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwtoac) ! retrieve time averaged surface clear sky outgoing SW VarName='csusf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswoutc) ! retrieve time averaged TOA clear sky outgoing LW VarName='csusftoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswtoac) ! retrieve time averaged surface clear sky incoming LW VarName='csdlf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,alwinc) ! retrieve time averaged surface clear sky incoming SW VarName='csdsf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,aswinc) ! retrieve shelter max specific humidity using nemsio VarName='spfhmax_max2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,maxqshltr) ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', ! 1,maxqshltr(isa,jsa) ! retrieve shelter min temperature using nemsio VarName='spfhmin_min2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,minqshltr) ! retrieve storm runoff using nemsio VarName='ssrun_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,SSROFF) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) ssroff(i,j) = spval enddo enddo ! retrieve direct soil evaporation VarName='evbs_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgedir) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) avgedir(i,j) = spval enddo enddo ! retrieve CANOPY WATER EVAP VarName='evcw_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgecan) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) avgecan(i,j) = spval enddo enddo ! retrieve PLANT TRANSPIRATION VarName='trans_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgetrans) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) avgetrans(i,j) = spval enddo enddo ! retrieve snow sublimation VarName='sbsno_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,avgesnow) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval enddo enddo ! retrive total soil moisture VarName='soilm' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,smstot) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) smstot(i,j) = spval enddo enddo ! retrieve snow phase change heat flux VarName='snohf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,snopcx) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) snopcx(i,j) = spval enddo enddo @@ -2351,7 +2354,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend HTOPD(i,j) = SPVAL HBOTD(i,j) = SPVAL HTOPS(i,j) = SPVAL @@ -2498,7 +2501,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) RETURN END - subroutine read_netcdf_3d_para(ncid,im,jm,jsta,jsta_2l,jend,jend_2u, & + subroutine read_netcdf_3d_para(ncid,im,jm,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,varname,buf,lm) use netcdf @@ -2508,8 +2511,9 @@ subroutine read_netcdf_3d_para(ncid,im,jm,jsta,jsta_2l,jend,jend_2u, & character(len=20),intent(in) :: varname real,intent(in) :: spval integer,intent(in) :: ncid,im,jm,lm,jsta_2l,jend_2u,jsta,jend - real,intent(out) :: buf(im,jsta_2l:jend_2u,lm) - integer :: varid,iret,jj,i,j,l,kk + integer,intent(in) :: ista_2l,iend_2u,ista,iend + real,intent(out) :: buf(ista_2l:iend_2u,jsta_2l:jend_2u,lm) + integer :: varid,iret,ii,jj,i,j,l,kk integer :: start(3), count(3), stride(3) iret = nf90_inq_varid(ncid,trim(varname),varid) @@ -2518,21 +2522,29 @@ subroutine read_netcdf_3d_para(ncid,im,jm,jsta,jsta_2l,jend,jend_2u, & !$omp parallel do private(i,j,l) do l=1,lm do j=jsta,jend - do i=1,im + do i=ista,iend buf(i,j,l)=spval enddo enddo enddo else - start = (/1,jsta,1/) +! start = (/1,jsta,1/) +! jj=jend-jsta+1 +! count = (/im,jj,lm/) +! iret = nf90_get_var(ncid,varid,buf(1:im,jsta:jend,1:lm),start=start,count=count) + start = (/ista,jsta,1/) jj=jend-jsta+1 - count = (/im,jj,lm/) - iret = nf90_get_var(ncid,varid,buf(1:im,jsta:jend,1:lm),start=start,count=count) + ii=iend-ista+1 + count = (/ii,jj,lm/) + iret = nf90_get_var(ncid,varid,buf(ista:iend,jsta:jend,1:lm),start=start,count=count) + if (iret /= 0) then + print*," iret /=0, not found -Assigned missing values",buf(30,30,2) + endif endif end subroutine read_netcdf_3d_para - subroutine read_netcdf_2d_para(ncid,im,jsta,jsta_2l,jend,jend_2u, & + subroutine read_netcdf_2d_para(ncid,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,buf) use netcdf @@ -2541,25 +2553,35 @@ subroutine read_netcdf_2d_para(ncid,im,jsta,jsta_2l,jend,jend_2u, & character(len=20),intent(in) :: VarName real,intent(in) :: spval - integer,intent(in) :: ncid,im,jsta_2l,jend_2u,jsta,jend - real,intent(out) :: buf(im,jsta_2l:jend_2u) - integer :: varid,iret,jj,i,j + integer,intent(in) :: ncid,jsta_2l,jend_2u,jsta,jend + integer,intent(in) :: ista_2l,iend_2u,ista,iend + real,intent(out) :: buf(ista_2l:iend_2u,jsta_2l:jend_2u) + integer :: varid,iret,ii,jj,i,j integer :: start(2), count(2) + iret = nf90_inq_varid(ncid,trim(varname),varid) if (iret /= 0) then print*,VarName," not found -Assigned missing values" !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend buf(i,j)=spval enddo enddo else - start = (/1,jsta/) +! start = (/1,jsta/) +! jj=jend-jsta+1 +! count = (/im,jj/) +! iret = nf90_get_var(ncid,varid,buf(:,jsta),start=start,count=count) + start = (/ista,jsta/) jj=jend-jsta+1 - count = (/im,jj/) - iret = nf90_get_var(ncid,varid,buf(:,jsta),start=start,count=count) + ii=iend-ista+1 + count = (/ii,jj/) + iret = nf90_get_var(ncid,varid,buf(ista:iend,jsta:jend),start=start,count=count) + if (iret /= 0) then + print*," iret /=0, not found -Assigned missing values",buf(30,30) + endif endif end subroutine read_netcdf_2d_para From c07c1cec22b3799867c7c35c6df1ca4c8c9e95f5 Mon Sep 17 00:00:00 2001 From: Bo Cui Date: Mon, 12 Jul 2021 09:41:49 -0400 Subject: [PATCH 20/77] test version INITPOST_GFS_NETCDF_PARA.f and MPI_FIRST.f --- sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f | 8 ++++---- sorc/ncep_post.fd/MPI_FIRST.f | 8 ++++++++ 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f index 090778d61..5b97161d8 100644 --- a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f +++ b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f @@ -78,7 +78,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(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,rdaod, & - ista, iend, ista_2l, iend_2u + 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 @@ -189,9 +189,9 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) 'jsta_2l=',jsta_2l,'jend_2u=', & jend_2u,'im=',im, & 'ista_2l=',ista_2l,'iend_2u=', & - iend_2u,'im=',im + iend_2u,'im=',im,'iend_m=',iend_m,'jend_m=',jend_m ! - isa = im / 2 + isa = (ista+iend) / 2 jsa = (jsta+jend) / 2 !$omp parallel do private(i,j) @@ -596,7 +596,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) !$omp parallel do private(i,j,ip1) do j = jsta, jend_m - do i = 1, im + do i = ista, iend_m ip1 = i + 1 if (ip1 > im) ip1 = ip1 - im DX (i,j) = ERAD*COS(GDLAT(I,J)*DTR) *(GDLON(IP1,J)-GDLON(I,J))*DTR diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 97a83c6d9..704abd186 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -141,13 +141,21 @@ SUBROUTINE MPI_FIRST() jsta_m2 = jsta jend_m = jend jend_m2 = jend + ista_m = ista + ista_m2 = ista + iend_m = iend + iend_m2 = iend if ( me == 0 ) then jsta_m = 2 jsta_m2 = 3 + ista_m = 2 + ista_m2 = 3 end if if ( me == num_procs - 1 ) then jend_m = jm - 1 jend_m2 = jm - 2 + iend_m = im - 1 + iend_m2 = im - 2 end if ! ! neighbors From 9c0326d873e06e8bdab11d7810e15ed5e11e7711 Mon Sep 17 00:00:00 2001 From: Bo Cui Date: Tue, 13 Jul 2021 11:31:55 -0400 Subject: [PATCH 21/77] 20210713 BoCui test INITPOST_GFS_NETCDF_PARA.f, MPI_FIRST.f and ALLOCATE_ALL.f --- sorc/ncep_post.fd/ALLOCATE_ALL.f | 994 +++++++++---------- sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f | 9 +- sorc/ncep_post.fd/MPI_FIRST.f | 41 +- 3 files changed, 533 insertions(+), 511 deletions(-) diff --git a/sorc/ncep_post.fd/ALLOCATE_ALL.f b/sorc/ncep_post.fd/ALLOCATE_ALL.f index 322ccb8ad..36142fe36 100644 --- a/sorc/ncep_post.fd/ALLOCATE_ALL.f +++ b/sorc/ncep_post.fd/ALLOCATE_ALL.f @@ -46,40 +46,40 @@ SUBROUTINE ALLOCATE_ALL() integer ierr,jsx,jex integer i,j,l,k ! Allocate arrays - allocate(u(im,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,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 + do i=ista_2l,iend_2u u(i,j,l)=0. v(i,j,l)=0. t(i,j,l)=spval @@ -107,7 +107,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 @@ -116,38 +116,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 @@ -179,23 +179,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 @@ -211,34 +211,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 @@ -266,21 +266,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 @@ -294,9 +294,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)) @@ -304,7 +304,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 @@ -321,25 +321,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 @@ -357,31 +357,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 @@ -407,60 +407,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 @@ -491,15 +491,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 @@ -508,20 +508,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 @@ -535,16 +535,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 @@ -554,33 +554,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 @@ -606,40 +606,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 @@ -660,32 +660,32 @@ 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(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(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 @@ -709,36 +709,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 @@ -767,37 +767,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 @@ -828,47 +828,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 @@ -908,48 +908,48 @@ 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(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)) !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 @@ -993,19 +993,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 @@ -1023,19 +1023,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 @@ -1045,7 +1045,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 @@ -1055,7 +1055,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 @@ -1065,7 +1065,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 @@ -1075,7 +1075,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 @@ -1084,15 +1084,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 @@ -1100,35 +1100,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 @@ -1140,7 +1140,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 @@ -1151,7 +1151,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 @@ -1163,7 +1163,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 @@ -1175,7 +1175,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 @@ -1184,52 +1184,52 @@ SUBROUTINE ALLOCATE_ALL() enddo enddo enddo - allocate(rhomid(im,jsta_2l:jend_2u,lm)) + allocate(rhomid(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) !Initialization !$omp parallel do private(i,j,l) do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u rhomid(i,j,l)=spval enddo enddo enddo ! vrbls2d - allocate(dusmass(im,jsta_2l:jend_2u)) - allocate(ducmass(im,jsta_2l:jend_2u)) - allocate(dusmass25(im,jsta_2l:jend_2u)) - allocate(ducmass25(im,jsta_2l:jend_2u)) - allocate(susmass(im,jsta_2l:jend_2u)) - allocate(sucmass(im,jsta_2l:jend_2u)) - allocate(susmass25(im,jsta_2l:jend_2u)) - allocate(sucmass25(im,jsta_2l:jend_2u)) - allocate(ocsmass(im,jsta_2l:jend_2u)) - allocate(occmass(im,jsta_2l:jend_2u)) - allocate(ocsmass25(im,jsta_2l:jend_2u)) - allocate(occmass25(im,jsta_2l:jend_2u)) - allocate(bcsmass(im,jsta_2l:jend_2u)) - allocate(bccmass(im,jsta_2l:jend_2u)) - allocate(bcsmass25(im,jsta_2l:jend_2u)) - allocate(bccmass25(im,jsta_2l:jend_2u)) - allocate(sssmass(im,jsta_2l:jend_2u)) - allocate(sscmass(im,jsta_2l:jend_2u)) - allocate(sssmass25(im,jsta_2l:jend_2u)) - allocate(sscmass25(im,jsta_2l:jend_2u)) - allocate(dustcb(im,jsta_2l:jend_2u)) - allocate(occb(im,jsta_2l:jend_2u)) - allocate(bccb(im,jsta_2l:jend_2u)) - allocate(sulfcb(im,jsta_2l:jend_2u)) - allocate(pp25cb(im,jsta_2l:jend_2u)) - allocate(pp10cb(im,jsta_2l:jend_2u)) - allocate(sscb(im,jsta_2l:jend_2u)) - allocate(dustallcb(im,jsta_2l:jend_2u)) - allocate(ssallcb(im,jsta_2l:jend_2u)) - allocate(dustpm(im,jsta_2l:jend_2u)) - allocate(sspm(im,jsta_2l:jend_2u)) + allocate(dusmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ducmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(dusmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ducmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(susmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sucmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(susmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sucmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ocsmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(occmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ocsmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(occmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(bcsmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(bccmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(bcsmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(bccmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sssmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sscmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sssmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sscmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(dustcb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(occb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(bccb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sulfcb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pp25cb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pp10cb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sscb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(dustallcb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ssallcb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(dustpm(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sspm(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 @@ -1265,13 +1265,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 @@ -1279,13 +1279,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 diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f index 5b97161d8..1ef423b9e 100644 --- a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f +++ b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f @@ -124,7 +124,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL ! logical, parameter :: debugprint = .true., zerout = .false. - logical, parameter :: debugprint = .false., zerout = .false. + logical, parameter :: debugprint = .false., zerout = .false. logical :: convert_rad_to_deg=.false. CHARACTER*32 varcharval ! CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC @@ -188,8 +188,9 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) WRITE(6,*)'me=',me, & 'jsta_2l=',jsta_2l,'jend_2u=', & jend_2u,'im=',im, & - 'ista_2l=',ista_2l,'iend_2u=', & - iend_2u,'im=',im,'iend_m=',iend_m,'jend_m=',jend_m + 'ista_2l=',ista_2l,'iend_2u=',iend_2u, & + 'ista=',ista,'iend=',iend, & + 'iend_m=',iend_m ! isa = (ista+iend) / 2 jsa = (jsta+jend) / 2 @@ -591,7 +592,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) print *,me,'max(gdlat)=', maxval(gdlat), & 'max(gdlon)=', maxval(gdlon) - CALL EXCH(gdlat(1,JSTA_2L)) +! CALL EXCH(gdlat(1,JSTA_2L)) print *,'after call EXCH,me=',me !$omp parallel do private(i,j,ip1) diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 704abd186..8da027023 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -145,18 +145,39 @@ SUBROUTINE MPI_FIRST() ista_m2 = ista iend_m = iend iend_m2 = iend - if ( me == 0 ) then - jsta_m = 2 - jsta_m2 = 3 - ista_m = 2 - ista_m2 = 3 + + if (me=(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 + +! if ( me == 0 ) then +! jsta_m = 2 +! jsta_m2 = 3 +! ista_m = 2 +! ista_m2 = 3 +! end if +! if ( me == num_procs - 1 ) then +! jend_m = jm - 1 +! jend_m2 = jm - 2 +! iend_m = im - 1 +! iend_m2 = im - 2 +! end if ! ! neighbors ! From 740640553f4dec1f60cceb74753fbbedf1dd574f Mon Sep 17 00:00:00 2001 From: Bo Cui Date: Wed, 14 Jul 2021 14:00:58 -0400 Subject: [PATCH 22/77] 20210713 BoCui test INITPOST_GFS_NETCDF_PARA.f, MPI_FIRST.f and ALLOCATE_ALL.f --- sorc/ncep_post.fd/DEALLOCATE.f | 1 + 1 file changed, 1 insertion(+) diff --git a/sorc/ncep_post.fd/DEALLOCATE.f b/sorc/ncep_post.fd/DEALLOCATE.f index bb80f4496..1bffc0515 100644 --- a/sorc/ncep_post.fd/DEALLOCATE.f +++ b/sorc/ncep_post.fd/DEALLOCATE.f @@ -206,6 +206,7 @@ SUBROUTINE DE_ALLOCATE deallocate(tsnow) deallocate(qvg) deallocate(qv2m) + deallocate(qvl1) deallocate(rswin) deallocate(swddni) deallocate(swddif) From f62b62f92f9d715536f67006e72117d0cf8e441c Mon Sep 17 00:00:00 2001 From: Bo Cui Date: Mon, 19 Jul 2021 22:38:52 -0400 Subject: [PATCH 23/77] 20210719 BoCui Modified CLDRAD.f for 2d decomposition --- sorc/ncep_post.fd/CLDRAD.f | 841 +++++++++++++++++++------------------ 1 file changed, 437 insertions(+), 404 deletions(-) diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index b76625746..af107b3e9 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -127,7 +127,7 @@ SUBROUTINE CLDRAD FLD_INFO, AVRAIN, THEAT, IFHR, IFMIN, AVCNVC, & TCLOD, ARDSW, TRDSW, ARDLW, NBIN_DU, TRDLW, IM, & NBIN_SS, NBIN_OC, NBIN_BC, NBIN_SU, DTQ2, & - JM, LM, gocart_on, me, rdaod + JM, LM, gocart_on, me, rdaod,ISTA, IEND use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD use gridspec_mod, only: dyval, gridtype use cmassi_mod, only: TRAD_ice @@ -144,10 +144,10 @@ SUBROUTINE CLDRAD ! ! LOGICAL,dimension(im,jm) :: NEED INTEGER :: lcbot,lctop,jc,ic !bsf - INTEGER,dimension(im,jsta:jend) :: IBOTT, IBOTCu, IBOTDCu, IBOTSCu, IBOTGr, & + INTEGER,dimension(ista:iend,jsta:jend) :: IBOTT, IBOTCu, IBOTDCu, IBOTSCu, IBOTGr, & ITOPT, ITOPCu, ITOPDCu, ITOPSCu, ITOPGr REAL,dimension(im,jm) :: GRID1 - REAL,dimension(im,jsta:jend) :: GRID2, EGRID1, EGRID2, EGRID3, & + REAL,dimension(ista:iend,jsta:jend) :: GRID2, EGRID1, EGRID2, EGRID3, & CLDP, CLDZ, CLDT, CLDZCu REAL,dimension(lm) :: RHB, watericetotal, pabovesfc REAL :: watericemax, wimin, zcldbase, zcldtop, zpbltop, & @@ -164,7 +164,7 @@ SUBROUTINE CLDRAD real,dimension(im,jm) :: ceil ! B ZHOU: For aviation: - REAL, dimension(im,jsta:jend) :: TCLD, CEILING + REAL, dimension(ista:iend,jsta:jend) :: TCLD, CEILING real CU_ir(LM), q_conv !bsf !jw integer I,J,L,K,IBOT,ITCLOD,LBOT,LTOP,ITRDSW,ITRDLW, & @@ -175,8 +175,8 @@ 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) ! ! --- Revision added for GOCART --- @@ -221,7 +221,7 @@ SUBROUTINE CLDRAD ! - relative humidity dependent aerosol optical properties: oc, bc, su, ss001-005 real (kind=kind_phys) :: extrhd(KRHLEV,KCM2,NBDSW) ! extinction coefficient ! - REAL,dimension(im,jsta:jend) :: P1D,T1D,Q1D,EGRID4 + REAL,dimension(ista:iend,jsta:jend) :: P1D,T1D,Q1D,EGRID4 ! REAL, allocatable :: RH3D(:,:,:) ! RELATIVE HUMIDITY real, allocatable:: rdrh(:,:,:) integer, allocatable :: ihh(:,:,:) @@ -229,10 +229,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 @@ -272,7 +272,7 @@ SUBROUTINE CLDRAD IF (IGET(030)>0.OR.IGET(572)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID1(I,J) = SPVAL ENDDO ENDDO @@ -282,14 +282,14 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'RAPR') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(EGRID1(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(EGRID1(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) + TFRZ ENDDO ENDDO @@ -299,11 +299,12 @@ SUBROUTINE CLDRAD if(grib == "grib2" )then cfld = cfld+1 fld_info(cfld)%ifld = IAVBLFLD(IGET(030)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -314,12 +315,13 @@ SUBROUTINE CLDRAD cfld = cfld+1 fld_info(cfld)%ifld = IAVBLFLD(IGET(572)) ! where(GRID1 /= SPVAL) GRID1 = GRID1-TFRZ -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - if (grid1(i,jj) /= spval) grid1(i,jj) = grid1(i,jj) - tfrz - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + if (grid1(ii,jj) /= spval) grid1(ii,jj) = grid1(ii,jj) - tfrz + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -343,7 +345,7 @@ SUBROUTINE CLDRAD EGRID3,dummy,dummy) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FIS(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -351,11 +353,12 @@ SUBROUTINE CLDRAD if(grib == "grib2" )then cfld = cfld+1 fld_info(cfld)%ifld = IAVBLFLD(IGET(032)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -371,7 +374,7 @@ SUBROUTINE CLDRAD IF ( (LVLS(1,IGET(032)) > 0) )THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FIS(I,J) < SPVAL) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -385,7 +388,7 @@ SUBROUTINE CLDRAD EGRID3,dummy,dummy) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FIS(I,J) < SPVAL) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -393,18 +396,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 @@ -419,7 +423,7 @@ SUBROUTINE CLDRAD GRID1 = spval CALL CALPW(GRID1(1,jsta),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 @@ -427,11 +431,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 @@ -446,11 +451,12 @@ SUBROUTINE CLDRAD 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 @@ -465,11 +471,12 @@ SUBROUTINE CLDRAD if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(736)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -481,7 +488,7 @@ 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 @@ -492,7 +499,7 @@ SUBROUTINE CLDRAD CALL CALPW(GRID2(1,jsta),3) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(GRID1(I,J)0 .OR. IGET(288)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=-5000. GRID2(I,J)=-5000. !-- Search for the base first, then look for the top if supercooled liquid exists @@ -868,24 +887,25 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(287)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(288)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=GRID2(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(288)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -897,14 +917,14 @@ SUBROUTINE CLDRAD ! from 0.2 (EFIMN in cuparm in model) to 1.0 (Ferrier, Feb '02) IF (IGET(197)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDEFI(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(197)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -916,7 +936,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. @@ -936,7 +956,7 @@ SUBROUTINE CLDRAD ! 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 @@ -1021,7 +1041,7 @@ SUBROUTINE CLDRAD IF (IGET(799)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=0.0 DO K = 1,LM IF (ZMID(I,J,LM-K+1) <= PBLH(I,J)+1000.0) THEN @@ -1033,7 +1053,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(799)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -1041,7 +1061,7 @@ SUBROUTINE CLDRAD IF (IGET(037) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(CFRACL(I,J) < SPVAL) then GRID1(I,J) = CFRACL(I,J)*100. else @@ -1052,11 +1072,12 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(037)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1066,7 +1087,7 @@ SUBROUTINE CLDRAD IF (IGET(300) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(AVGCFRACL(I,J) < SPVAL) then GRID1(I,J) = AVGCFRACL(I,J)*100. else @@ -1102,11 +1123,12 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1117,7 +1139,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(CFRACM(I,J) < SPVAL) then GRID1(I,J) = CFRACM(I,J)*100. else @@ -1128,11 +1150,12 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(038)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1142,7 +1165,7 @@ SUBROUTINE CLDRAD IF (IGET(301) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ABS(AVGCFRACM(I,J)-SPVAL)>SMALL)THEN GRID1(I,J) = AVGCFRACM(I,J)*100. ELSE @@ -1178,11 +1201,12 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1193,7 +1217,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(CFRACH(I,J) < SPVAL) then GRID1(I,J) = CFRACH(I,J)*100. else @@ -1204,11 +1228,12 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(039)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1219,7 +1244,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(AVGCFRACH(I,J) < SPVAL) then GRID1(I,J) = AVGCFRACH(I,J)*100. else @@ -1255,11 +1280,12 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1271,7 +1297,7 @@ SUBROUTINE CLDRAD IF(MODELNAME=='NCAR' .OR. MODELNAME=='RAPR')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(i,j) = SPVAL egrid1(i,j)=0. do l = 1,LM @@ -1283,7 +1309,7 @@ SUBROUTINE CLDRAD ELSE IF (MODELNAME=='NMM'.OR.MODELNAME=='FV3R' & .OR. MODELNAME=='GFS')THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! EGRID1(I,J)=AMAX1(CFRACL(I,J), ! 1 AMAX1(CFRACM(I,J),CFRACH(I,J))) ! EGRID1(I,J)=1.-(1.-CFRACL(I,J))*(1.-CFRACM(I,J))* & @@ -1295,7 +1321,7 @@ SUBROUTINE CLDRAD END IF !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ABS(EGRID1(I,J)-SPVAL) > SMALL) THEN GRID1(I,J) = EGRID1(I,J)*100. TCLD(I,J) = EGRID1(I,J)*100. !B ZHOU, PASSED to CALCEILING @@ -1306,11 +1332,12 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(161)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1323,7 +1350,7 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ABS(AVGTCDC(I,J)-SPVAL) > SMALL) then GRID1(I,J) = AVGTCDC(I,J)*100. else @@ -1334,7 +1361,7 @@ SUBROUTINE CLDRAD ELSE IF(MODELNAME == 'NMM')THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! RSUM = NCFRST(I,J)+NCFRCV(I,J) ! IF (RSUM>0.0) THEN ! EGRID1(I,J)=(ACFRST(I,J)+ACFRCV(I,J))/RSUM @@ -1385,11 +1412,12 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1401,7 +1429,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (NCFRST(I,J)0.0) THEN GRID1(I,J) = ACFRST(I,J)/NCFRST(I,J)*100. @@ -1443,7 +1471,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -1453,7 +1481,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (NCFRCV(I,J)0.0) THEN GRID1(I,J) = ACFRCV(I,J)/NCFRCV(I,J)*100. @@ -1495,7 +1523,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -1513,7 +1541,7 @@ SUBROUTINE CLDRAD !--- Rain is not part of cloud, only cloud water + cloud ice + snow ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! !--- Various convective cloud base & cloud top levels ! @@ -1644,14 +1672,14 @@ SUBROUTINE CLDRAD IF (IGET(758)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDZCu(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(758)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -1663,7 +1691,7 @@ SUBROUTINE CLDRAD ! IF ((IGET(148)>0) .OR. (IGET(178)>0) .OR.(IGET(260)>0) ) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IBOT=IBOTT(I,J) !-- Cloud base ("bottoms") IF(MODELNAME == 'RAPR') then IF (IBOT <= 0) THEN @@ -1694,28 +1722,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 @@ -1746,8 +1774,7 @@ SUBROUTINE CLDRAD Cloud_def_p = 0.0000001 DO J=JSTA,JEND - - DO I=1,IM + DO I=ISTA,IEND ! !- imported from RUC post IF(MODELNAME == 'RAPR') then @@ -1939,7 +1966,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 @@ -1950,14 +1977,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 @@ -1974,7 +2001,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. @@ -2045,14 +2072,14 @@ SUBROUTINE CLDRAD ! proceed to gridding 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 @@ -2075,7 +2102,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 @@ -2193,7 +2220,7 @@ 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 @@ -2202,7 +2229,7 @@ SUBROUTINE CLDRAD CALL AllGETHERV(full_fis) 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) @@ -2230,14 +2257,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 @@ -2245,14 +2272,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 @@ -2263,32 +2290,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 @@ -2300,13 +2328,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) @@ -2319,11 +2347,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 @@ -2333,7 +2362,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) @@ -2345,14 +2374,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) @@ -2364,14 +2393,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) @@ -2383,7 +2412,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 @@ -2391,7 +2420,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 @@ -2427,14 +2456,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 @@ -2470,14 +2499,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 @@ -2513,7 +2542,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 ! @@ -2526,7 +2555,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 @@ -2594,7 +2623,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. @@ -2658,28 +2687,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 @@ -2688,14 +2717,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 ! @@ -2704,7 +2733,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 @@ -2793,7 +2822,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 @@ -2804,13 +2833,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) @@ -2823,11 +2852,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 @@ -2837,7 +2867,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) @@ -2849,14 +2879,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) @@ -2868,7 +2898,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 ! @@ -2876,7 +2906,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) @@ -2888,7 +2918,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 @@ -2896,7 +2926,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 @@ -2932,14 +2962,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 @@ -2971,14 +3001,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 @@ -3010,7 +3040,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 @@ -3018,7 +3048,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 @@ -3050,14 +3080,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 @@ -3089,14 +3119,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 @@ -3127,7 +3157,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 ! @@ -3136,7 +3166,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 @@ -3144,13 +3174,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 @@ -3160,7 +3190,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 @@ -3192,7 +3222,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 ! @@ -3200,7 +3230,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 @@ -3232,7 +3262,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 ! @@ -3252,7 +3282,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 @@ -3288,7 +3318,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 ! @@ -3305,7 +3335,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 @@ -3342,7 +3372,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 ! @@ -3359,7 +3389,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 @@ -3396,7 +3426,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 ! @@ -3412,7 +3442,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 @@ -3448,7 +3478,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 ! @@ -3464,7 +3494,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 @@ -3500,7 +3530,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 ! @@ -3516,7 +3546,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 @@ -3552,7 +3582,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 ! @@ -3568,7 +3598,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 @@ -3604,7 +3634,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 ! @@ -3620,7 +3650,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 @@ -3656,7 +3686,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 ! @@ -3666,7 +3696,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 @@ -3674,7 +3704,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 ! @@ -3685,7 +3715,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 @@ -3694,7 +3724,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 ! @@ -3702,7 +3732,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) @@ -3717,7 +3747,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 ! @@ -3726,7 +3756,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 @@ -3747,7 +3777,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 ! @@ -3756,7 +3786,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) @@ -3771,21 +3801,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 @@ -3793,42 +3823,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 @@ -3836,7 +3866,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 @@ -3844,7 +3874,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 @@ -3853,7 +3883,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) @@ -3867,21 +3897,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 @@ -3889,28 +3919,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 @@ -3918,35 +3948,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 @@ -3977,14 +4007,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 @@ -4015,28 +4045,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 @@ -4067,14 +4097,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 @@ -4105,14 +4135,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 @@ -4143,14 +4173,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 @@ -4181,14 +4211,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 @@ -4219,14 +4249,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 @@ -4259,14 +4289,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 @@ -4298,14 +4328,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 @@ -4337,14 +4367,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 @@ -4376,7 +4406,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 @@ -4384,80 +4414,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 @@ -4465,42 +4495,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 ! @@ -4686,14 +4716,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) @@ -4701,7 +4731,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) @@ -4789,7 +4819,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) @@ -4816,7 +4846,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 @@ -4850,7 +4880,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 @@ -4883,7 +4913,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 @@ -4915,7 +4945,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 @@ -4945,7 +4975,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) @@ -4977,7 +5007,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 @@ -4986,7 +5016,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 @@ -4997,7 +5027,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 @@ -5005,7 +5035,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 ! @@ -5017,7 +5047,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) @@ -5032,7 +5062,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) @@ -5041,7 +5071,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) @@ -5056,7 +5086,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' @@ -5072,7 +5102,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 @@ -5080,7 +5110,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 @@ -5091,7 +5121,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) @@ -5103,7 +5133,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 @@ -5112,7 +5142,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) @@ -5124,7 +5154,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 @@ -5141,7 +5171,7 @@ SUBROUTINE CLDRAD ANG2 = LOG ( 860. / 440. ) !$omp parallel do private(i,j) 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 @@ -5149,13 +5179,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 @@ -5166,7 +5196,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 @@ -5217,7 +5247,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 @@ -5225,7 +5255,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 @@ -5233,14 +5263,14 @@ 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 !! 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 @@ -5254,7 +5284,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 @@ -5262,7 +5292,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 @@ -5270,14 +5300,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 @@ -5285,7 +5315,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 @@ -5293,7 +5323,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 @@ -5301,7 +5331,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) ! @@ -5309,7 +5339,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 @@ -5545,17 +5575,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 @@ -5563,17 +5594,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 @@ -5581,17 +5613,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 @@ -5607,9 +5640,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 @@ -5629,7 +5662,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. @@ -5660,12 +5693,12 @@ 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 @@ -5673,7 +5706,7 @@ subroutine wrt_aero_diag(igetfld,nbin,data) GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = ISTA,IEND if(data(I,J,1) Date: Mon, 16 Aug 2021 15:58:14 +0000 Subject: [PATCH 24/77] 20210816 Jesse Meng commit George's EXCH update for 1 layer 2D halos transforming --- sorc/ncep_post.fd/CTLBLK.f | 6 + sorc/ncep_post.fd/EXCH.f | 229 ++++++++++- sorc/ncep_post.fd/MDL2P.f | 741 +++++++++++++++++++--------------- sorc/ncep_post.fd/MPI_FIRST.f | 108 ++++- sorc/ncep_post.fd/SLP_new.f | 38 +- 5 files changed, 749 insertions(+), 373 deletions(-) diff --git a/sorc/ncep_post.fd/CTLBLK.f b/sorc/ncep_post.fd/CTLBLK.f index e84a1d0f1..9550e3cac 100644 --- a/sorc/ncep_post.fd/CTLBLK.f +++ b/sorc/ncep_post.fd/CTLBLK.f @@ -62,7 +62,13 @@ module CTLBLK_mod ISTA_2L, IEND_2U,IVEND_2U, & NUM_SERVERS, MPI_COMM_INTER, & MPI_COMM_COMP, IM,JM,LM,NSOIL,LP1,LM1,IM_JM, & + ileft,iright, & + ibsize,ibsum, & lsm,lsmp1 !comm mpi + integer, allocatable :: icoords(:,:),ibcoords(:,:) + real, allocatable :: bufs(:),buff(:) + integer , allocatable :: isxa(:),iexa(:),jsxa(:),jexa(:) + integer, allocatable :: ibufs(:) ! real :: ARDSW, ARDLW, ASRFC, TSRFC,TRDLW,TRDSW,TCLOD,THEAT, & TPREC,TMAXMIN,TD3D !comm rad diff --git a/sorc/ncep_post.fd/EXCH.f b/sorc/ncep_post.fd/EXCH.f index 7cb3b5908..965eb8e89 100644 --- a/sorc/ncep_post.fd/EXCH.f +++ b/sorc/ncep_post.fd/EXCH.f @@ -33,41 +33,253 @@ ! makefile (Tuccillo, personal communication; Ferrier, Feb '02). ! SUBROUTINE EXCH(A) + use ifcore + use ctlblk_mod, only: num_procs, jend, iup, jsta, idn, mpi_comm_comp, im,& - jsta_2l, jend_2u + icoords,ibcoords,bufs,ibufs,me, & ! GWV TMP + + jsta_2l, jend_2u,ileft,iright,ista_2l,iend_2u,ista,iend,jm !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! include 'mpif.h' ! - real,intent(inout) :: a ( im,jsta_2l:jend_2u ) +! 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 !GWV + allocate(coll(jm)) + allocate(colr(jm)) + allocate(icolr(jm)) !GWV + allocate(icoll(jm)) !GWV + 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 ! 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) + 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) + 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 +! build the I columns to send and receive + 902 format(' GWVX EXCH BOUNDS ',18i8) + msglenl=jend-jsta+1 + msglenr=jend-jsta+1 + if(iright .lt. 0) msglenr=1 + if(ileft .lt. 0) msglenl=1 +!gwv write(0,902),lbound(a),ubound(a),lbound(coll),ubound(coll),ista,jsta,jend,jend-jsta+1,msglenl,msglenr + do j=jsta,jend + coll(j)=a(ista,j) + icoll(j)=icoords(ista,j) !GWV TMP + 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) + call mpi_sendrecv(icoll(jsta),msglenl ,MPI_INTEGER,ileft,1, & !GWV TMP + & icolr(jsta),msglenr ,MPI_INTEGER,iright,1, & !GWV TMP + & MPI_COMM_COMP,status,ierr) + if(iright .gt. 0) then + do j=jsta,jend + a(iend+1,j)=colr(j) +!GWV ibcoords(iend+1,j)=icolr(j) !GWV TMP + ibcoords(iend+1,j)=icolr(j) !GWV TMP +! write(0,*) ' GWVX IBCOLL SETT2 ',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 ) & + write(0,921) j,iend+1,ii,jj,ibcoords(iend+1,j),' GWVX EXCH COORD FAIL j,iend+1,ii,jj,ibcoord ' + 921 format(5i10,a50) +! + + end do + endif + ! print *,'mype=',me,'in EXCH, after first mpi_sendrecv' if ( ierr /= 0 ) then print *, ' problem with first sendrecv in exch, ierr = ',ierr - stop + stop 6667 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, +!GWVt of 2D decomp + do j=jsta,jend + colr(j)=a(iend,j) + icolr(j)=icoords(iend,j) !GWV TMP + 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) + 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) +! 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) + call mpi_sendrecv(icolr(jsta),msglenr ,MPI_integer,iright,1 , & + & icoll(jsta),msglenl ,MPI_integer,ileft ,1, & + & MPI_COMM_COMP,status,ierr) + if(ileft .ge. 0) then + do j=jsta,jend + a(ista-1,j)=coll(j) +!GWV ibcoords(ista-1,j)=icoll(j) !GWV TMP + ibcoords(ista-1,j)=icoll(j) !GWV TMP +! write(0,*) ' GWVX IBCOLL SETT ',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) & + write(0,921) j,ista-1,ii,jj,ibcoords(ista-1,j),' GWVX EXCH COORD FAIL j,ista-1,ii,jj,ibcoord ' + end do + endif +!! 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 + ibl=max(ista-1,1) + ibu=min(im,iend+1) + 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) + + call mpi_sendrecv(a(iend,jbu ),1, MPI_REAL,iright,1 , & + & a(ibl ,jbu ),1, MPI_REAL,ileft ,1, & + & MPI_COMM_COMP,status,ierr) + call mpi_sendrecv(a(ista,jbl ),1, MPI_REAL,ileft ,1, & + & a(ibu ,jbl ),1, MPI_REAL,iright,1, & + & MPI_COMM_COMP,status,ierr) + call mpi_sendrecv(a(ista,jbu ),1, MPI_REAL,ileft ,1 , & + & a(ibu ,jbu ),1, MPI_REAL,iright,1, & + & MPI_COMM_COMP,status,ierr) +!GWV TEST +! write(0,139)' GWVX PRE CORNER ' ,ibcoords(iend,jsta-1),iend,jsta-1,ibcoords(iend,jsta+1),iend,jsta+1,& +! ibcoords(ista,jend+1),ista,jend+1,ibcoords(ista,jend-1),ista,jend-1,me,ileft,iright + 139 format(a20,5(i10,i6,i6,'<>')) + + 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 .or. jj .ne. jcc) write(0,151) ' CORNER FAIL 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 .or. jj .ne. jcc) write(0,151) ' CORNER FAIL 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 .or. jj .ne. jcc) write(0,151) ' CORNER FAIL ilb uu ',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 .or. jj .ne. jcc) write(0,151) ' CORNER FAIL ilb lu ',icc,jcc,ibcoords(icc,jcc),ii,jj + + ! print *,'mype=',me,'in EXCH, after second mpi_sendrecv' + if(ileft .ge. 0) then +! write(0,119) ileft,me,ibcoords(ista-1,jend+1),ibcoords(ista-1,jend-1),ista-1,jend-1,jend+1 + 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 + 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 + do j=jbl,jbu + do i=ibl,ibu +! 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 + 151 format(a20,10i10) + end do + end do + + 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 FAILED 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 FAILED JBL IJ ',i,j,ibcoords(i,j),ibl,jbl,ibu,jbu + end do + i=ibl + do j=jsta,jend + ii=ibcoords(i,j)/10000 + jj=ibcoords( i,j)-(ii*10000) + if(ii .ne. i .or. jj .ne. j) write(0,151) 'GWVX FAILED IBL IJ ',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 .or. jj .ne. j) write(0,151) 'GWVX FAILED IBU IJ ',i,j,ibcoords(i,j),ibl,jbl,ibu,jbu + end do if ( ierr /= 0 ) then print *, ' problem with second sendrecv in exch, ierr = ',ierr stop end if + call mpi_barrier(mpi_comm_comp,ierr) +! write(0,*) ' GWVX END EXCHHH ' ! end @@ -89,6 +301,7 @@ subroutine exch_f(a) real,intent(inout) :: a ( im,jsta_2l:jend_2u ) integer status(MPI_STATUS_SIZE) integer ierr, jstam1, jendp1 + write(0,*) ' called EXCH_F GWVX' ! if ( num_procs == 1 ) return ! diff --git a/sorc/ncep_post.fd/MDL2P.f b/sorc/ncep_post.fd/MDL2P.f index 8f1d27d79..a3cb90d52 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -84,7 +84,7 @@ 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 @@ -104,7 +104,7 @@ SUBROUTINE MDL2P(iostatusD3D) real,PARAMETER :: CAPA=0.28589641,P1000=1000.E2 LOGICAL IOOMG,IOALL real, dimension(im,jm) :: GRID1, GRID2 - real, dimension(im,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL & + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL & &, Q2SL, WSL, CFRSL, O3SL, TDSL & &, EGRID1, EGRID2 & &, FSL_OLD, USL_OLD, VSL_OLD & @@ -113,8 +113,8 @@ SUBROUTINE MDL2P(iostatusD3D) REAL, allocatable :: D3DSL(:,:,:), DUSTSL(:,:,:), SMOKESL(:,:,:) ! integer,intent(in) :: iostatusD3D - INTEGER, dimension(im,jsta_2l:jend_2u) :: NL1X, NL1XF - real, dimension(IM,JSTA_2L:JEND_2U,LSM) :: TPRS, QPRS, FPRS + INTEGER, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: NL1X, NL1XF + real, dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LSM) :: TPRS, QPRS, FPRS ! INTEGER K, NSMOOTH ! @@ -128,15 +128,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 @@ -251,7 +251,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! !$omp parallel do private(i,j,l) DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U TSL(I,J) = SPVAL QSL(I,J) = SPVAL FSL(I,J) = SPVAL @@ -312,12 +312,12 @@ SUBROUTINE MDL2P(iostatusD3D) !hc J=JHOLD(NN) ! DO 220 J=JSTA,JEND - ii = im/2 + ii = (ista+iend)/2 jj = (jsta+jend)/2 !$omp parallel do private(i,j,k,l,ll,llmh,la,tvd,tvu,fact,fac,ahf,rhl,tl,pl,ql,zl,es,qsat,part,tvrl,tvrblo,tblo,qblo,gammas,pnl1) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC !*** HUMIDITY, CLOUD WATER/ICE, OMEGA, WINDS, AND TKE. @@ -785,7 +785,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND TPRS(I,J,LP) = TSL(I,J) QPRS(I,J,LP) = QSL(I,J) FPRS(I,J,LP) = FSL(I,J) @@ -796,7 +796,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,IEND ! IF(i == im/2 .and. j == (jsta+jend)/2)then ! do l=1,lm ! print*,'PMIDV=',PMIDV(i,j,l) @@ -870,8 +871,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 LL = NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF WINDS FOR A-E GRID @@ -925,7 +926,8 @@ SUBROUTINE MDL2P(iostatusD3D) END DO ELSE IF(gridtype=='B')THEN ! B grid wind interpolation DO J=JSTA,JEND_m - DO I=1,IM-1 +! DO I=1,IM-1 + DO I=ISTA,IEND_m !*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. ! @@ -955,8 +957,8 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO ! DO J=JSTA,JEND_m - DO I=1,IM-1 - +! DO I=1,IM-1 + DO I=ISTA,IEND_m LL = NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF WINDS FOR A-E GRID @@ -1013,7 +1015,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(NINT(SPL(LP)) == 50000)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND T500(I,J) = TSL(I,J) Z500(I,J) = FSL(I,J)*GI ENDDO @@ -1026,7 +1028,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(NINT(SPL(LP)) == 70000)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND T700(I,J) = TSL(I,J) Z700(I,J) = FSL(I,J)*GI ENDDO @@ -1098,7 +1100,7 @@ SUBROUTINE MDL2P(iostatusD3D) ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FSL(I,J) < SPVAL) THEN GRID1(I,J) = FSL(I,J)*GI ELSE @@ -1130,11 +1132,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(012)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(012)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1149,7 +1152,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(013)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TSL(I,J) ENDDO ENDDO @@ -1166,11 +1169,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(013)) fld_info(cfld)%lvl = LVLSXML(LP,IGET(013)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1183,7 +1187,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(910))>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(TSL(I,J) < SPVAL .AND. QSL(I,J) < SPVAL) THEN GRID1(I,J) = TSL(I,J)*(1.+0.608*QSL(I,J)) ELSE @@ -1204,11 +1208,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld=cfld+1 fld_info(cfld)%ifld = IAVBLFLD(IGET(910)) fld_info(cfld)%lvl = LVLSXML(LP,IGET(910)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1224,7 +1229,7 @@ SUBROUTINE MDL2P(iostatusD3D) tem = (P1000/spl(lp)) ** capa !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(TSL(I,J) < SPVAL) THEN grid1(I,J) = TSL(I,J) * tem ELSE @@ -1251,11 +1256,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(014)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(014)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1278,16 +1284,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,jsta),TSL(ista,jsta),QSL(ista,jsta),EGRID1(ista,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(EGRID1(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J)*100. ELSE @@ -1307,18 +1313,19 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(017)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(017)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND SAVRH(I,J) = GRID1(I,J) ENDDO ENDDO @@ -1332,7 +1339,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(331)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SPVAL CFRSL(I,J) = MIN(MAX(0.0,CFRSL(I,J)),1.0) IF(abs(CFRSL(I,J)-SPVAL) > SMALL) & @@ -1343,11 +1350,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(331)) fld_info(cfld)%lvl = LVLSXML(LP,IGET(331)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1360,15 +1368,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,jsta),QSL(ista,jsta),EGRID1(ista,jsta),TSL(ista,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(TSL(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J) ELSE @@ -1380,11 +1388,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(015)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(015)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1397,7 +1406,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(016)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QSL(I,J) ENDDO ENDDO @@ -1406,11 +1415,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(016)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(016)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1423,7 +1433,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(020)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = OSL(I,J) ENDDO ENDDO @@ -1449,11 +1459,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(020)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(020)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1466,7 +1477,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(284)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = WSL(I,J) ENDDO ENDDO @@ -1474,11 +1485,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(284)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(284)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1489,11 +1501,11 @@ 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 @@ -1506,11 +1518,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(085)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(085)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo ! if(me==0) print *,'in mdl2p,mconv, lp=',fld_info(cfld)%lvl,'lp=',lp @@ -1531,7 +1544,7 @@ SUBROUTINE MDL2P(iostatusD3D) if ( log1 ) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = USL(I,J) GRID2(I,J) = VSL(I,J) ENDDO @@ -1554,22 +1567,24 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(018)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(018)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(019)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(019)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -1584,7 +1599,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! print *,'me=',me,'EGRID1=',EGRID1(1:10,JSTA) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1610,11 +1625,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(021)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(021)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1626,16 +1642,16 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(086)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FSL(I,J) 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = Q2SL(I,J) ENDDO ENDDO @@ -1672,11 +1689,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(022)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(022)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1691,7 +1709,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! GFS does not seperate cloud water from ice, hoping to do that in Feb 08 implementation !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(QW1(I,J) < SPVAL .AND. QI1(I,J) < SPVAL) THEN GRID1(I,J) = QW1(I,J) + QI1(I,J) QI1(I,J) = spval @@ -1703,7 +1721,7 @@ SUBROUTINE MDL2P(iostatusD3D) ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QW1(I,J) ENDDO ENDDO @@ -1712,11 +1730,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(153)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(153)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1729,7 +1748,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(166)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QI1(I,J) ENDDO ENDDO @@ -1737,11 +1756,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(166)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(166)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1753,7 +1773,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(183)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QR1(I,J) ENDDO ENDDO @@ -1761,11 +1781,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(183)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(183)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1777,7 +1798,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(184)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QS1(I,J) ENDDO ENDDO @@ -1785,11 +1806,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(184)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(184)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1801,7 +1823,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(416)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QG1(I,J) ENDDO ENDDO @@ -1809,11 +1831,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(416)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(416)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1826,7 +1849,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(198)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = C1D(I,J) ENDDO ENDDO @@ -1834,11 +1857,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(198)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(198)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1850,7 +1874,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(263)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = FRIME(I,J) ENDDO ENDDO @@ -1858,11 +1882,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(263)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(263)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1874,7 +1899,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(294)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RAD(I,J) ENDDO ENDDO @@ -1882,11 +1907,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(294)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(294)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1898,7 +1924,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(251)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DBZ1(I,J) ENDDO ENDDO @@ -1906,11 +1932,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(251)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(251)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1920,11 +1947,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,jsta), SAVRH, OSL(ista,jsta), EGRID1(ista,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 @@ -1932,11 +1959,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(257)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(257)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1951,7 +1979,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(258)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FSL(I,J) 3. .OR. GRID1(I,J) < 0.) ! + print*,'bad CAT',i,j,GRID1(I,J) @@ -1975,11 +2003,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(258)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(258)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1990,7 +2019,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U USL_OLD(I,J) = USL(I,J) VSL_OLD(I,J) = VSL(I,J) IF(FSL(I,J) 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = O3SL(I,J) ENDDO ENDDO @@ -2016,11 +2045,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(268)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(268)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2032,7 +2062,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(738)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(SMOKESL(I,J,1) 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DUSTSL(I,J,1) ENDDO ENDDO @@ -2068,11 +2099,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(438)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(438)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2083,7 +2115,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(439)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DUSTSL(I,J,2) ENDDO ENDDO @@ -2091,11 +2123,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(439)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(439)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2106,7 +2139,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(440)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DUSTSL(I,J,3) ENDDO ENDDO @@ -2114,11 +2147,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(440)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(440)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2129,7 +2163,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(441)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DUSTSL(I,J,4) ENDDO ENDDO @@ -2137,11 +2171,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(441)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(441)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2152,7 +2187,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(442)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DUSTSL(I,J,5) ENDDO ENDDO @@ -2160,11 +2195,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(442)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(442)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2179,7 +2215,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(355)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,1) ENDDO ENDDO @@ -2211,11 +2247,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2226,7 +2263,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(354)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,2) ENDDO ENDDO @@ -2258,11 +2295,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2273,7 +2311,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(356)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,3) ENDDO ENDDO @@ -2305,11 +2343,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2320,7 +2359,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(357)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,4) ENDDO ENDDO @@ -2352,11 +2391,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2367,7 +2407,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(358)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,5) ENDDO ENDDO @@ -2399,11 +2439,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2414,7 +2455,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(359)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,6) ENDDO ENDDO @@ -2446,11 +2487,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2461,7 +2503,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(360)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,7) ENDDO ENDDO @@ -2493,11 +2535,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2508,7 +2551,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(361)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,8) ENDDO ENDDO @@ -2540,11 +2583,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2555,7 +2599,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(362)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,9) ENDDO ENDDO @@ -2587,11 +2631,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2602,7 +2647,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(363)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,10) ENDDO ENDDO @@ -2635,11 +2680,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2650,7 +2696,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(364)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,11) ENDDO ENDDO @@ -2683,11 +2729,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2698,7 +2745,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(365)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,12) ENDDO ENDDO @@ -2731,11 +2778,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2746,7 +2794,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(366)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,13) ENDDO ENDDO @@ -2779,11 +2827,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2794,7 +2843,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(367)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,14) ENDDO ENDDO @@ -2827,11 +2876,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2842,7 +2892,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(368)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,15) ENDDO ENDDO @@ -2875,11 +2925,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2890,7 +2941,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(369)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,16) ENDDO ENDDO @@ -2922,11 +2973,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2937,7 +2989,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(370)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,17) ENDDO ENDDO @@ -2970,11 +3022,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2985,7 +3038,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(371)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,18) ENDDO ENDDO @@ -3018,11 +3071,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3033,7 +3087,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(372)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,19) ENDDO ENDDO @@ -3065,11 +3119,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3080,7 +3135,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(373)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,20) ENDDO ENDDO @@ -3113,11 +3168,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3128,7 +3184,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(374)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,21) ENDDO ENDDO @@ -3161,11 +3217,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3176,7 +3233,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(375)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,22) ENDDO ENDDO @@ -3208,11 +3265,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3223,7 +3281,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(379)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(D3DSL(i,j,1)/=SPVAL)THEN GRID1(I,J) = D3DSL(i,j,1) + D3DSL(i,j,2) & + D3DSL(i,j,3) + D3DSL(i,j,4) & @@ -3261,11 +3319,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3276,7 +3335,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(391)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,23) ENDDO ENDDO @@ -3309,11 +3368,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3324,7 +3384,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(392)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,24) ENDDO ENDDO @@ -3357,11 +3417,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3372,7 +3433,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(393)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,25) ENDDO ENDDO @@ -3405,11 +3466,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3420,7 +3482,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(394)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,26) ENDDO ENDDO @@ -3453,11 +3515,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3468,7 +3531,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(395)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,27) ENDDO ENDDO @@ -3501,11 +3564,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3515,7 +3579,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! CHUANG: COMPUTE HAINES INDEX IF (IGET(455) > 0) THEN - ii=im/2+100 + ii=(ista+iend)/2+100 jj=(jsta+jend)/2-100 IF(ABS(SPL(LP)-50000.) 17. .AND. DUM1 <= 21.) THEN - ISTA = 2 + ISTAA = 2 ELSE - ISTA = 3 + ISTAA = 3 END IF DUM1 = TSL(I,J)-TDSL(I,J) IF(DUM1 <= 14.) THEN @@ -3551,7 +3615,7 @@ SUBROUTINE MDL2P(iostatusD3D) IMOIS = 3 END IF IF(TSL(I,J) 5. .AND. DUM1 <= 10.) THEN - ISTA = 2 + ISTAA = 2 ELSE - ISTA = 3 + ISTAA = 3 END IF DUM1 = TSL(I,J)-TDSL(I,J) IF(DUM1 <= 5.) THEN @@ -3597,7 +3661,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! if(i==570 .and. j==574)print*,'mid haines index:',i,j,luhi,tsl(i,j) & ! ,tprs(i,j,luhi),tdsl(i,j),ista,imois,spl(luhi),spl(lp),haines(i,j) IF(TSL(I,J) 3. .AND. DUM1 <=7. ) THEN - ISTA = 2 + ISTAA = 2 ELSE - ISTA = 3 + ISTAA = 3 END IF DUM1 = TSL(I,J)-TDSL(I,J) IF(DUM1 <=5. ) THEN @@ -3641,7 +3705,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) Date: Fri, 3 Sep 2021 10:36:07 -0400 Subject: [PATCH 26/77] 20210903 Bo Cui update ALLOCATE_ALL.f after new merge from 'upstream/develop' --- sorc/ncep_post.fd/ALLOCATE_ALL.f | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/sorc/ncep_post.fd/ALLOCATE_ALL.f b/sorc/ncep_post.fd/ALLOCATE_ALL.f index 93ef7b511..fb527ca0d 100644 --- a/sorc/ncep_post.fd/ALLOCATE_ALL.f +++ b/sorc/ncep_post.fd/ALLOCATE_ALL.f @@ -87,7 +87,7 @@ SUBROUTINE ALLOCATE_ALL() !$omp parallel do private(i,j,l) do l=1,lm do j=jsta_2l,jvend_2u - do i=1,im + do i=ista_2l,iend_2u v(i,j,l)=0. enddo enddo @@ -95,7 +95,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 @@ -1311,14 +1311,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 From 61e2056f791614acd0024f3ac4975b64d408a439 Mon Sep 17 00:00:00 2001 From: Bo Cui Date: Fri, 3 Sep 2021 11:16:44 -0400 Subject: [PATCH 27/77] 20210903 Bo Cui Added new routines to 2D decomposition --- sorc/ncep_post.fd/AVIATION.f | 59 +++++++++++++++--------------- sorc/ncep_post.fd/AllGETHERV_GSD.f | 11 +++--- sorc/ncep_post.fd/BNDLYR.f | 57 +++++++++++++++-------------- 3 files changed, 65 insertions(+), 62 deletions(-) diff --git a/sorc/ncep_post.fd/AVIATION.f b/sorc/ncep_post.fd/AVIATION.f index 4de228f92..b8cc2f509 100644 --- a/sorc/ncep_post.fd/AVIATION.f +++ b/sorc/ncep_post.fd/AVIATION.f @@ -6,6 +6,7 @@ !! PRGRMMR: Binbin Zhou /NCEP/EMC DATE: 2005-08-16 !! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT !! 21-04-01 Jesse Meng - computation on defined points only +!! 21-09-02 Bo Cui - Decompose UPP in X direction !! !! ABSTRACT: !! This program computes the low level wind shear(LLWS) over 0-2000 feet (0-609.5m) @@ -84,7 +85,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 ! @@ -101,7 +102,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) @@ -196,20 +197,20 @@ SUBROUTINE CALICING (T1,RH,OMGA, ICING) ! MACHINE : BLUE AT NCEP !$$$ ! - 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) :: 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) & @@ -277,7 +278,7 @@ 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 ! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -286,10 +287,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) @@ -305,22 +306,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 @@ -329,12 +330,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 @@ -531,20 +532,20 @@ 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 @@ -605,14 +606,14 @@ 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 ! @@ -620,7 +621,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..43008353a 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 @@ -54,7 +55,7 @@ SUBROUTINE AllGETHERV(GRID1) ij=0 do j=1,JM - do i=1,IM + do i=1,IM ij=ij+1 GRID1(i,j)=ibufrecv(ij) enddo diff --git a/sorc/ncep_post.fd/BNDLYR.f b/sorc/ncep_post.fd/BNDLYR.f index 0ec21e25d..329d37ed9 100644 --- a/sorc/ncep_post.fd/BNDLYR.f +++ b/sorc/ncep_post.fd/BNDLYR.f @@ -32,6 +32,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 directio !! !! USAGE: CALL BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, !! WBND,OMGBND,PWTBND,QCNVBND) @@ -73,7 +74,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 @@ -83,12 +84,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(:,:,:) @@ -101,19 +102,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 @@ -121,7 +122,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 @@ -131,7 +132,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) @@ -140,7 +141,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 @@ -156,7 +157,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 @@ -179,7 +180,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 Date: Fri, 3 Sep 2021 18:24:07 +0000 Subject: [PATCH 28/77] 20210903 Jesse Meng fixed the ieql allocation bug in ALLOCATE_ALL.f --- sorc/ncep_post.fd/ALLOCATE_ALL.f | 1 + 1 file changed, 1 insertion(+) diff --git a/sorc/ncep_post.fd/ALLOCATE_ALL.f b/sorc/ncep_post.fd/ALLOCATE_ALL.f index fb527ca0d..5de245469 100644 --- a/sorc/ncep_post.fd/ALLOCATE_ALL.f +++ b/sorc/ncep_post.fd/ALLOCATE_ALL.f @@ -683,6 +683,7 @@ SUBROUTINE ALLOCATE_ALL() 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)) From 03a793b953e88516618d0d514b6e946b7e95ebad Mon Sep 17 00:00:00 2001 From: Bo Cui Date: Sat, 4 Sep 2021 10:27:59 -0400 Subject: [PATCH 29/77] 20210904 Bo Cui fixed CLDRAD.f --- sorc/ncep_post.fd/CLDRAD.f | 2 ++ 1 file changed, 2 insertions(+) diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index 4e08b1a03..dfa1dfc6e 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -519,6 +519,7 @@ SUBROUTINE CLDRAD do j=1,jend-jsta+1 jj = jsta+j-1 do i=1,iend-ista+1 + ii=ista+i-1 datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo @@ -532,6 +533,7 @@ SUBROUTINE CLDRAD do j=1,jend-jsta+1 jj = jsta+j-1 do i=1,iend-ista+1 + ii=ista+i-1 datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo From 70e502b546cb841b73610ed8230dadca88604502 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Mon, 13 Sep 2021 21:10:06 +0000 Subject: [PATCH 30/77] 20210913 Jesse Meng commit progress of 2D decomposition --- sorc/ncep_post.fd/CLDRAD.f | 14 +- sorc/ncep_post.fd/COLLECT_LOC.f | 50 +- sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f | 43 +- sorc/ncep_post.fd/MDL2P.f | 3 +- sorc/ncep_post.fd/MDLFLD.f | 19 +- sorc/ncep_post.fd/MPI_FIRST.f | 1 + sorc/ncep_post.fd/SURFCE.f | 1274 ++++++++++-------- sorc/ncep_post.fd/TRPAUS.f | 9 +- sorc/ncep_post.fd/TRPAUS_NAM.f | 9 +- sorc/ncep_post.fd/TTBLEX.f | 18 +- sorc/ncep_post.fd/WETBULB.f | 26 +- sorc/ncep_post.fd/WETFRZLVL.f | 10 +- sorc/ncep_post.fd/WRFPOST.f | 1 + sorc/ncep_post.fd/grib2_module.f | 29 +- 14 files changed, 830 insertions(+), 676 deletions(-) diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index dfa1dfc6e..9ce24163f 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -515,7 +515,7 @@ SUBROUTINE CLDRAD if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(200)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 do i=1,iend-ista+1 @@ -529,7 +529,7 @@ SUBROUTINE CLDRAD if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(575)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 do i=1,iend-ista+1 @@ -721,7 +721,7 @@ SUBROUTINE CLDRAD ELSE RRNUM = 0. ENDIF -!$omp parallel do +!$omp parallel do private(i,j) DO J=JSTA,JEND DO I=ISTA,IEND IF(GRID1(I,J) < SPVAL) GRID1(I,J) = GRID1(I,J)*RRNUM @@ -772,7 +772,7 @@ SUBROUTINE CLDRAD ELSE RRNUM = 0. ENDIF -!$omp parallel do +!$omp parallel do private(i,j) DO J=JSTA,JEND DO I=ISTA,IEND IF(GRID1(I,J) < SPVAL) GRID1(I,J) = GRID1(I,J)*RRNUM @@ -1041,7 +1041,7 @@ 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=ISTA,IEND GRID1(I,J)=0.0 @@ -5174,7 +5174,7 @@ 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=ISTA,IEND IF (AOD_860(I,J) > 0.) THEN @@ -5709,7 +5709,7 @@ subroutine wrt_aero_diag(igetfld,nbin,data) 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 = ISTA,IEND if(data(I,J,1)ug/m3 ENDDO @@ -2272,11 +2274,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 diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index b9ae4e9a2..189b3bcf6 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -13,6 +13,7 @@ !! 02-06-19 MIKE BALDWIN - WRF VERSION !! 11-12-16 SARAH LU - MODIFIED TO INITIALIZE AEROSOL FIELDS !! 12-01-07 SARAH LU - MODIFIED TO INITIALIZE AIR DENSITY/LAYER THICKNESS +!! 21-07-07 JESSE MENG - 2D DECOMPOSITION !! !! USAGE: CALL MPI_FIRST !! INPUT ARGUMENT LIST: diff --git a/sorc/ncep_post.fd/SURFCE.f b/sorc/ncep_post.fd/SURFCE.f index 749e5cdd0..665daea3d 100644 --- a/sorc/ncep_post.fd/SURFCE.f +++ b/sorc/ncep_post.fd/SURFCE.f @@ -39,6 +39,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-09-13 J MENG - 2D DECOMPOSITION !! !! USAGE: CALL SURFCE !! INPUT ARGUMENT LIST: @@ -101,7 +102,8 @@ SUBROUTINE SURFCE modelname, tmaxmin, pthresh, dtq2, dt, nphs, & ifhr, prec_acc_dt, sdat, ihrst, jsta_2l, jend_2u,& lp1, imp_physics, me, asrfc, tsrfc, pt, pdtop, & - mpi_comm_comp, im, jm, prec_acc_dt1 + mpi_comm_comp, im, jm, prec_acc_dt1, & + ista, iend, ista_2l, iend_2u use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml use upp_physics, only: fpvsnew, CALRH !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -124,7 +126,7 @@ SUBROUTINE SURFCE ! ! DECLARE VARIABLES. ! - integer, dimension(im,jsta:jend) :: nroots, iwx1 + integer, dimension(ista:iend,jsta:jend) :: nroots, iwx1 real, allocatable, dimension(:,:) :: zsfc, psfc, tsfc, qsfc, & rhsfc, thsfc, dwpsfc, p1d, & t1d, q1d, zwet, & @@ -132,11 +134,11 @@ SUBROUTINE SURFCE domip, domzr, rsmin, smcref,& rcq, rct, rcsoil, gc, rcs - real, dimension(im,jsta:jend) :: evp - real, dimension(im,jsta_2l:jend_2u) :: egrid1, egrid2 - real, dimension(im,jsta_2l:jend_2u) :: grid2 + real, dimension(ista:iend,jsta:jend) :: evp + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: egrid1, egrid2 + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: grid2 real, dimension(im,jm) :: grid1 - real, dimension(im,jsta_2l:jend_2u) :: iceg + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: iceg ! , ua, va real, allocatable, dimension(:,:,:) :: sleet, rain, freezr, snow ! real, dimension(im,jm,nalg) :: sleet, rain, freezr, snow @@ -171,11 +173,11 @@ SUBROUTINE SURFCE (IGET(154)>0).OR. & (IGET(034)>0).OR.(IGET(076)>0) ) THEN ! - allocate(zsfc(im,jsta:jend), psfc(im,jsta:jend), tsfc(im,jsta:jend)& - ,rhsfc(im,jsta:jend), thsfc(im,jsta:jend), qsfc(im,jsta:jend)) + allocate(zsfc(ista:iend,jsta:jend), psfc(ista:iend,jsta:jend), tsfc(ista:iend,jsta:jend)& + ,rhsfc(ista:iend,jsta:jend), thsfc(ista:iend,jsta:jend), qsfc(ista:iend,jsta:jend)) !$omp parallel do private(i,j,tsfck,qsat,es) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! ! SCALE ARRAY FIS BY GI TO GET SURFACE HEIGHT. ! ZSFC(I,J)=FIS(I,J)*GI @@ -241,11 +243,12 @@ SUBROUTINE SURFCE if(grib == 'grib2') then cfld = cfld+1 fld_info(cfld)%ifld = IAVBLFLD(IGET(024)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = PSFC(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = PSFC(ii,jj) enddo enddo endif @@ -257,11 +260,12 @@ SUBROUTINE SURFCE if(grib == 'grib2') then cfld=cfld+1 fld_info(cfld)%ifld = IAVBLFLD(IGET(025)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = ZSFC(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = ZSFC(ii,jj) enddo enddo endif @@ -274,11 +278,12 @@ SUBROUTINE SURFCE if(grib == 'grib2') then cfld = cfld+1 fld_info(cfld)%ifld = IAVBLFLD(IGET(026)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = TSFC(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = TSFC(ii,jj) enddo enddo endif @@ -290,11 +295,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(027)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = THSFC(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = THSFC(ii,jj) enddo enddo endif @@ -307,11 +313,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(028)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = QSFC(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = QSFC(ii,jj) enddo enddo endif @@ -320,16 +327,17 @@ SUBROUTINE SURFCE ! ! SURFACE DEWPOINT TEMPERATURE. IF (IGET(029)>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 @@ -342,11 +350,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 @@ -362,11 +371,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 @@ -378,11 +388,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 @@ -393,11 +404,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 @@ -408,11 +420,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 @@ -449,8 +462,9 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,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 @@ -472,11 +486,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 @@ -492,11 +507,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 @@ -513,11 +529,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 @@ -531,11 +548,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 @@ -550,11 +568,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 @@ -568,11 +587,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 @@ -588,11 +608,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 @@ -600,11 +621,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 @@ -614,7 +636,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 @@ -625,11 +647,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 @@ -639,7 +662,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 @@ -654,11 +677,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 @@ -669,7 +693,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 @@ -680,7 +704,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 @@ -692,11 +716,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 @@ -708,11 +733,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 @@ -723,7 +749,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) @@ -759,11 +785,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 @@ -785,10 +812,11 @@ 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 + do i=1,iend-ista+1 + ii = ista+i-1 datapd(i,j,cfld) = PSFCAVG(i,jj) enddo enddo @@ -814,11 +842,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 @@ -828,7 +857,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 @@ -857,7 +886,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 ! @@ -865,7 +894,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) @@ -883,20 +912,21 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,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 @@ -905,11 +935,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 @@ -919,11 +950,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 @@ -933,11 +965,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 @@ -959,10 +992,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 @@ -988,11 +1021,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 @@ -1002,11 +1036,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 @@ -1016,7 +1051,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 @@ -1024,7 +1059,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 @@ -1032,11 +1067,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 @@ -1046,11 +1082,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 @@ -1070,11 +1107,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 @@ -1108,11 +1146,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 @@ -1146,11 +1185,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 @@ -1184,7 +1224,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 @@ -1216,7 +1256,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 @@ -1234,12 +1274,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) @@ -1256,7 +1296,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 @@ -1265,12 +1305,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 ! @@ -1278,21 +1318,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 @@ -1300,30 +1340,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 @@ -1345,14 +1385,14 @@ SUBROUTINE SURFCE ENDIF ENDDO ENDDO - CALL DEWPOINT(EVP,EGRID1(1,jsta)) + CALL DEWPOINT(EVP,EGRID1(ista,jsta)) ! 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) @@ -1360,7 +1400,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 @@ -1368,7 +1408,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 @@ -1377,7 +1417,7 @@ 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 @@ -1386,7 +1426,7 @@ SUBROUTINE SURFCE ! 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 @@ -1394,7 +1434,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 !------------------------------------------------------------------------- @@ -1404,7 +1444,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)) @@ -1424,7 +1464,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 @@ -1432,7 +1472,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 @@ -1442,10 +1482,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) @@ -1459,12 +1499,12 @@ SUBROUTINE SURFCE ENDDO ENDDO - CALL CALRH(P1D,T1D,Q1D,EGRID1(1,jsta)) + CALL CALRH(P1D,T1D,Q1D,EGRID1(ista,jsta)) 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 @@ -1480,8 +1520,9 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1491,7 +1532,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 @@ -1568,7 +1611,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 @@ -1602,11 +1645,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 @@ -1616,7 +1660,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 @@ -1648,11 +1692,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 @@ -1662,7 +1707,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 @@ -1703,8 +1748,9 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1714,7 +1760,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 @@ -1750,11 +1796,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 @@ -1790,11 +1837,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 @@ -1829,11 +1877,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 @@ -1844,7 +1893,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 @@ -1852,7 +1901,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 ! @@ -1865,7 +1914,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 @@ -1873,20 +1922,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 @@ -1895,7 +1946,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 @@ -1911,7 +1962,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 !--- @@ -1919,7 +1970,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 @@ -1934,14 +1985,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 @@ -1956,14 +2007,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 @@ -1978,14 +2029,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 @@ -2000,7 +2051,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 ! @@ -2015,7 +2066,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 @@ -2025,22 +2076,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 @@ -2053,7 +2106,7 @@ 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 @@ -2063,8 +2116,9 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2075,18 +2129,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 @@ -2097,18 +2152,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 @@ -2121,7 +2177,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 @@ -2134,11 +2190,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 @@ -2149,7 +2206,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 @@ -2162,11 +2219,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 @@ -2177,7 +2235,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 @@ -2190,10 +2248,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 @@ -2208,10 +2267,10 @@ SUBROUTINE SURFCE ! IF (IGET(588)>0) THEN - CALL CALVESSEL(ICEG(1,jsta)) + CALL CALVESSEL(ICEG(ista,jsta)) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ICEG(I,J) ENDDO ENDDO @@ -2226,11 +2285,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 @@ -2256,7 +2316,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 @@ -2267,11 +2327,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 @@ -2285,7 +2346,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 @@ -2293,11 +2354,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 @@ -2311,7 +2373,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. @@ -2327,8 +2389,9 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,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 +2402,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 @@ -2353,11 +2416,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 @@ -2368,7 +2432,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 @@ -2382,11 +2446,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 @@ -2419,7 +2484,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 @@ -2441,8 +2506,9 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2476,7 +2542,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 @@ -2492,11 +2558,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 @@ -2527,7 +2594,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 @@ -2537,7 +2604,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 @@ -2548,7 +2615,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 @@ -2570,11 +2637,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 @@ -2621,7 +2689,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 @@ -2639,11 +2707,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 @@ -2676,7 +2745,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 @@ -2687,7 +2756,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 @@ -2698,7 +2767,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 @@ -2713,11 +2782,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 @@ -2763,7 +2833,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 @@ -2780,11 +2850,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 @@ -2818,7 +2889,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 @@ -2829,7 +2900,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 @@ -2841,7 +2912,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 @@ -2852,11 +2923,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 @@ -2867,8 +2939,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 @@ -2902,7 +2975,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 @@ -2920,11 +2993,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 @@ -2936,7 +3010,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 @@ -2971,11 +3045,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 @@ -2985,7 +3060,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 @@ -3016,11 +3091,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 @@ -3030,7 +3106,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 @@ -3060,11 +3136,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 @@ -3074,7 +3151,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 @@ -3104,11 +3181,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 @@ -3118,7 +3196,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 @@ -3149,11 +3227,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 @@ -3163,7 +3242,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 @@ -3194,11 +3273,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 @@ -3208,7 +3288,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 @@ -3247,11 +3327,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 @@ -3261,7 +3342,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 @@ -3300,11 +3381,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 @@ -3314,7 +3396,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 @@ -3347,11 +3429,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 @@ -3362,7 +3445,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 @@ -3409,11 +3492,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 @@ -3424,7 +3508,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 @@ -3478,11 +3562,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 @@ -3492,7 +3577,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 @@ -3539,11 +3624,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 @@ -3553,7 +3639,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 @@ -3597,11 +3683,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 @@ -3611,7 +3698,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 @@ -3655,11 +3742,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 @@ -3671,7 +3759,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 @@ -3691,11 +3779,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 @@ -3704,7 +3793,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 @@ -3724,11 +3813,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 @@ -3737,7 +3827,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 @@ -3757,11 +3847,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 @@ -3770,7 +3861,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 @@ -3791,11 +3882,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 @@ -3804,7 +3896,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 @@ -3825,11 +3917,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 @@ -3839,9 +3932,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' @@ -3849,7 +3942,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 @@ -3900,7 +3994,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 @@ -3923,7 +4017,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 @@ -3939,7 +4033,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 @@ -3955,7 +4049,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 @@ -3965,7 +4059,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 @@ -3974,27 +4068,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 @@ -4002,18 +4097,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 @@ -4021,7 +4117,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) @@ -4034,11 +4130,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 @@ -4046,18 +4143,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 @@ -4067,16 +4165,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 @@ -4423,7 +4525,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 @@ -4544,7 +4646,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 @@ -4561,7 +4663,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 @@ -4575,25 +4677,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 @@ -4603,18 +4706,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) @@ -4625,29 +4729,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 @@ -4676,7 +4782,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 @@ -4711,7 +4817,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 @@ -4729,7 +4835,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 @@ -4765,7 +4871,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 ! @@ -4783,7 +4889,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 @@ -4815,7 +4921,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 ! @@ -4833,7 +4939,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 @@ -4865,7 +4971,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 ! @@ -4882,7 +4988,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 @@ -4918,7 +5024,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 ! @@ -4936,7 +5042,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 @@ -4968,7 +5074,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 ! @@ -4986,7 +5092,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 @@ -5018,7 +5124,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 ! @@ -5026,7 +5132,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 @@ -5060,7 +5166,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 @@ -5069,7 +5175,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 @@ -5103,35 +5209,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 ! @@ -5141,39 +5247,39 @@ SUBROUTINE SURFCE GRID1=spval CALL CALDRG(EGRID1(1,jsta_2l)) 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 ! @@ -5183,14 +5289,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 @@ -5198,14 +5304,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 @@ -5215,13 +5321,13 @@ SUBROUTINE SURFCE ! dong add missing value GRID1 = spval IF(MODELNAME /= 'FV3R') & - CALL CALTAU(EGRID1(1,jsta),EGRID2(1,jsta)) + CALL CALTAU(EGRID1(ista,jsta),EGRID2(ista,jsta)) ! ! 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 @@ -5233,14 +5339,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 @@ -5251,7 +5357,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 @@ -5262,7 +5368,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 @@ -5293,14 +5399,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 @@ -5331,7 +5437,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 @@ -5344,14 +5450,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 @@ -5359,7 +5465,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 ! @@ -5371,14 +5477,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 @@ -5386,21 +5492,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 ! @@ -5408,14 +5514,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 @@ -5424,14 +5530,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 ! @@ -5439,14 +5545,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 ! @@ -5456,7 +5562,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 @@ -5467,7 +5573,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 @@ -5476,54 +5582,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' @@ -5539,10 +5645,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 @@ -5585,118 +5691,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 @@ -5718,7 +5824,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)) @@ -5730,11 +5836,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 @@ -5743,7 +5850,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)) @@ -5758,8 +5865,9 @@ SUBROUTINE SURFCE !$omp parallel do private(i,j,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -5768,7 +5876,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 @@ -5799,11 +5907,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 @@ -5812,7 +5921,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 @@ -5843,11 +5952,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 @@ -5859,21 +5969,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 @@ -5890,14 +6000,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 @@ -5914,7 +6024,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 @@ -5922,7 +6032,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 @@ -5940,14 +6050,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 @@ -5965,7 +6075,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 diff --git a/sorc/ncep_post.fd/TRPAUS.f b/sorc/ncep_post.fd/TRPAUS.f index 2523717b5..becf1b8bd 100644 --- a/sorc/ncep_post.fd/TRPAUS.f +++ b/sorc/ncep_post.fd/TRPAUS.f @@ -22,7 +22,7 @@ !! 00-01-04 JIM TUCCILLO - MPI VERSION !! 02-04-23 MIKE BALDWIN - WRF VERSION !! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT - +!! 21-09-13 JESSE MENG - 2D DECOMPOSITION !! !! USAGE: CALL TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) !! INPUT ARGUMENT LIST: @@ -57,7 +57,8 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) use vrbls3d, only: pint, t, zint, uh, vh use masks, only: lmh use params_mod, only: d50 - use ctlblk_mod, only: jsta, jend, spval, im, jm, lm + use ctlblk_mod, only: jsta, jend, spval, im, jm, lm, & + ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -82,7 +83,7 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) ! LOOP OVER THE HORIZONTAL GRID. ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PTROP(I,J) = SPVAL TTROP(I,J) = SPVAL ZTROP(I,J) = SPVAL @@ -97,7 +98,7 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) !!$omp& tlapse,tlapse2,u0,u0l,uh,uh0,ul, !!$omp& v0,v0l,vh,vh0) DO J=JSTA,JEND - loopI:DO I=1,IM + loopI:DO I=ISTA,IEND ! ! COMPUTE THE TEMPERATURE LAPSE RATE (-DT/DZ) BETWEEN ETA ! LAYERS MOVING UP FROM THE GROUND. THE FIRST ETA LAYER diff --git a/sorc/ncep_post.fd/TRPAUS_NAM.f b/sorc/ncep_post.fd/TRPAUS_NAM.f index caf8785f4..738e55a8a 100644 --- a/sorc/ncep_post.fd/TRPAUS_NAM.f +++ b/sorc/ncep_post.fd/TRPAUS_NAM.f @@ -22,6 +22,7 @@ !! - 00-01-04 JIM TUCCILLO - MPI VERSION !! - 02-04-23 MIKE BALDWIN - WRF VERSION !! - 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT +!! - 21-09-13 JESSE MENG - 2D DECOMPOSITION !! !! USAGE: CALL TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) !! INPUT ARGUMENT LIST: @@ -59,8 +60,8 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) ! ! DECLARE VARIABLES. ! - REAL PTROP(IM,JM),TTROP(IM,JM),ZTROP(IM,JM),UTROP(IM,JM) - REAL VTROP(IM,JM),SHTROP(IM,JM) + REAL PTROP(ISTA:IEND,JSTA:JEND),TTROP(ISTA:IEND,JSTA:JEND),ZTROP(ISTA:IEND,JSTA:JEND),UTROP(ISTA:IEND,JSTA:JEND) + REAL VTROP(ISTA:IEND,JSTA:JEND),SHTROP(ISTA:IEND,JSTA:JEND) REAL TLAPSE(LM),DZ2(LM),DELT2(LM),TLAPSE2(LM) ! integer I,J @@ -72,7 +73,7 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) ! LOOP OVER THE HORIZONTAL GRID. ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PTROP(I,J) = SPVAL TTROP(I,J) = SPVAL ZTROP(I,J) = SPVAL @@ -87,7 +88,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/WETBULB.f b/sorc/ncep_post.fd/WETBULB.f index f22ba0368..f63b9c73b 100644 --- a/sorc/ncep_post.fd/WETBULB.f +++ b/sorc/ncep_post.fd/WETBULB.f @@ -8,6 +8,7 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET) ! MODIFIED FOR HYBRID: OCT 2001, H CHUANG ! 02-01-15 MIKE BALDWIN - WRF VERSION ! 21-07-26 Wen Meng - Restrict compuation from undefined grids +! 21-09-13 Jesse Meng- 2D DECOMPOSITION ! !----------------------------------------------------------------------- ! ROUTINE TO COMPUTE WET BULB TEMPERATURES USING THE LOOK UP TABLE @@ -23,7 +24,8 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET) use lookup_mod, only: thl, rdth, jtb, qs0, sqs, rdq, itb, ptbl, plq, ttbl,& pl, rdp, the0, sthe, rdthe, ttblq, itbq, jtbq, rdpq, the0q, stheq,& rdtheq - use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, lm, spval + use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, lm, spval, & + ista, iend, ista_2l, iend_2u use cuparm_mod, only: h10e5, capa, epsq, d00, elocp !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -39,14 +41,14 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET) ! SUBROUTINES CALLED: ! TTBLEX ! - real,dimension(IM,jsta_2l:jend_2u,LM),intent(in) :: T,Q, & + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,LM),intent(in) :: T,Q, & PMID,HTM - integer,dimension(IM,jsta:jend), intent(in) :: KARR - real,dimension(IM,jsta_2l:jend_2u,LM),intent(out) :: TWET + integer,dimension(ista:iend,jsta:jend), intent(in) :: KARR + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,LM),intent(out) :: TWET - real, dimension(im,jsta:jend) :: THESP, QQ, PP - integer, dimension(im,jsta:jend) :: KLRES,KHRES,IPTB,ITHTB + real, dimension(ista:iend,jsta:jend) :: THESP, QQ, PP + integer, dimension(ista:iend,jsta:jend) :: KLRES,KHRES,IPTB,ITHTB ! integer I,J,L,ITTB1,ITTBK,IQTBK,IT,KNUML,KNUMH,IQ real TBTK,QBTK,APEBTK,TTHBTK,TTHK,QQK,BQS00K,SQS00K,BQS10K, & @@ -62,7 +64,7 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET) !----------------------------------------------------------------------- DO 300 L=1,LM DO 125 J=JSTA,JEND - DO 125 I=1,IM + DO 125 I=ISTA,IEND IF (HTM(I,J,L)<1.0) THEN THESP(I,J)=273.15 cycle @@ -132,7 +134,7 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET) KNUMH=0 ! DO 280 J=JSTA,JEND - DO 280 I=1,IM + DO 280 I=ISTA,IEND KLRES(I,J)=0 KHRES(I,J)=0 ! @@ -153,16 +155,16 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET) !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE0)THEN - CALL TTBLEX(TWET(1,jsta_2l,L),TTBL,ITB,JTB,KLRES & - ,PMID(1,jsta_2l,L),PL,QQ,PP,RDP,THE0,STHE & + CALL TTBLEX(TWET(ista_2l,jsta_2l,L),TTBL,ITB,JTB,KLRES & + ,PMID(ista_2l,jsta_2l,L),PL,QQ,PP,RDP,THE0,STHE & ,RDTHE,THESP,IPTB,ITHTB) ENDIF !*** !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PL !** IF(KNUMH>0)THEN - CALL TTBLEX(TWET(1,jsta_2l,L),TTBLQ,ITBQ,JTBQ,KHRES & - ,PMID(1,jsta_2l,L),PLQ,QQ,PP,RDPQ,THE0Q,STHEQ & + CALL TTBLEX(TWET(ista_2l,jsta_2l,L),TTBLQ,ITBQ,JTBQ,KHRES & + ,PMID(ista_2l,jsta_2l,L),PLQ,QQ,PP,RDPQ,THE0Q,STHEQ & ,RDTHEQ,THESP,IPTB,ITHTB) ENDIF !----------------------------------------------------------------------- diff --git a/sorc/ncep_post.fd/WETFRZLVL.f b/sorc/ncep_post.fd/WETFRZLVL.f index a3aeeede5..6bb9edafd 100644 --- a/sorc/ncep_post.fd/WETFRZLVL.f +++ b/sorc/ncep_post.fd/WETFRZLVL.f @@ -21,6 +21,7 @@ !! 04-12-06 G MANIKIN - CORRECTED COMPUTATION OF SFC TEMPERATURE !! 05-03-11 H CHUANG - WRF VERSION !! 21-07-26 W Meng - Restrict computation from undefined grids +!! 21-09-13 J Meng - 2D DECOMPOSITION !! !! USAGE: CALL WETFRZLVL(TWET,ZWET) !! INPUT ARGUMENT LIST: @@ -55,14 +56,15 @@ SUBROUTINE WETFRZLVL(TWET,ZWET) use vrbls2d, only: fis, thz0, ths use masks, only: lmh, sm use params_mod, only: gi, p1000, capa, tfrz, d0065, d50 - use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, lm, spval + use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, lm, spval, & + ista, iend, ista_2l, iend_2u !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! DECLARE VARIABLES. ! - REAL,intent(in) :: TWET(IM,JSTA_2L:JEND_2U,LM) - REAL,intent(out) :: ZWET(IM,jsta:jend) + REAL,intent(in) :: TWET(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM) + REAL,intent(out) :: ZWET(ista:iend,jsta:jend) ! integer I,J,LLMH,L real HTSFC,THSFC,PSFC,TSFC,DELZ,DELT,ZL,ZU @@ -75,7 +77,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 a53e4c3bd..b675cd6f5 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -42,6 +42,7 @@ !! add gocart_on,d3d_on and popascal to namelist !! 20-03-25 J MENG - remove grib1 !! 21-06-20 W Meng - remove reading grib1 and gfsio lib +!! 21-07-07 J MENG - 2D DECOMPOSITION !! !! USAGE: WRFPOST !! INPUT ARGUMENT LIST: diff --git a/sorc/ncep_post.fd/grib2_module.f b/sorc/ncep_post.fd/grib2_module.f index 947702e1a..57170235a 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 ! @@ -219,7 +220,6 @@ subroutine gribit2(post_fname) integer,allocatable :: grbmsglen(:) real,allocatable :: datafld(:,:) real,allocatable :: datafldtmp(:) - real,allocatable :: datafldtmp2(:,:,:) logical, parameter :: debugprint = .false. ! character(1), dimension(:), allocatable :: cgrib @@ -281,14 +281,14 @@ subroutine gribit2(post_fname) ! !-- 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 @@ -359,14 +359,12 @@ subroutine gribit2(post_fname) ! print *,'in grib2,iscnt=',iscnt(1:num_procs),'ircnt=',ircnt(1:num_procs), & ! 'nfld_pe=',nfld_pe(me+1) allocate(datafldtmp(im_jm*nfld_pe(me+1)) ) - allocate(datafldtmp2(im,jm,nfld_pe(me+1)) ) allocate(datafld(im_jm,nfld_pe(me+1)) ) ! call mpi_alltoallv(datapd,iscnt,isdsp,MPI_REAL, & datafldtmp,ircnt,irdsp,MPI_REAL,MPI_COMM_COMP,ierr) ! !--- re-arrange the data - datafldtmp2=0. datafld=0. nm=0 do n=1,num_procs @@ -374,22 +372,13 @@ subroutine gribit2(post_fname) do j=jsta_pe(n),jend_pe(n) do i=ista_pe(n),iend_pe(n) nm=nm+1 - datafldtmp2(i,j,k)=datafldtmp(nm) - enddo + datafld((j-1)*im+i,k)=datafldtmp(nm) enddo enddo enddo - - do k=1,nfld_pe(me+1) - do j=1,jm - do i=1,im - datafld((j-1)*im+i,k)=datafldtmp2(i,j,k) - enddo - enddo enddo deallocate(datafldtmp) - deallocate(datafldtmp2) ! !-- now each process has several full domain fields, start to create grib2 message. ! From b502992e594bac2a9526b3a3a81dec3178a0c92e Mon Sep 17 00:00:00 2001 From: Bo Cui Date: Fri, 17 Sep 2021 10:13:01 -0400 Subject: [PATCH 31/77] 20210917 Bo Cui add new routines to 2D decomposition --- sorc/ncep_post.fd/BOUND.f | 5 +++-- sorc/ncep_post.fd/CALDRG.f | 15 ++++++++------- sorc/ncep_post.fd/CALDWP.f | 13 +++++++------ sorc/ncep_post.fd/CALMCVG.f | 11 ++++++----- 4 files changed, 24 insertions(+), 20 deletions(-) diff --git a/sorc/ncep_post.fd/BOUND.f b/sorc/ncep_post.fd/BOUND.f index dc439336d..b491a3731 100644 --- a/sorc/ncep_post.fd/BOUND.f +++ b/sorc/ncep_post.fd/BOUND.f @@ -18,6 +18,7 @@ !! 98-05-29 BLACK - CONVERSION FROM 1-D TO 2-D !! 00-01-04 JIM TUCCILLO - MPI VERSION !! 02-04-24 MIKE BALDWIN - WRF VERSION +!! 21-09-02 Bo Cui - Decompose UPP in X direction !! !! USAGE: CALL bound(fld,fmin,fmax) !! INPUT ARGUMENT LIST: @@ -43,7 +44,7 @@ SUBROUTINE BOUND(FLD,FMIN,FMAX) ! - use ctlblk_mod, only: jsta, jend, spval, im, jm + use ctlblk_mod, only: jsta, jend, spval, im, jm, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -59,7 +60,7 @@ SUBROUTINE BOUND(FLD,FMIN,FMAX) ! BOUND ARRAY. !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(fld(i,j) /= spval) then FLD(I,J) = min(FMAX, MAX(FMIN,FLD(I,J))) end if diff --git a/sorc/ncep_post.fd/CALDRG.f b/sorc/ncep_post.fd/CALDRG.f index 88f0d6038..b2865212e 100644 --- a/sorc/ncep_post.fd/CALDRG.f +++ b/sorc/ncep_post.fd/CALDRG.f @@ -14,6 +14,7 @@ !! 00-01-04 JIM TUCCILLO - MPI VERSION !! 02-01-15 MIKE BALDWIN - WRF VERSION !! 05-02-22 H CHUANG - ADD WRF NMM COMPONENTS +!! 21-09-02 Bo Cui - Decompose UPP in X direction !! !! USAGE: CALL CALDRG(DRAGCO) !! INPUT ARGUMENT LIST: @@ -46,7 +47,7 @@ SUBROUTINE CALDRG(DRAGCO) use masks, only: lmh use params_mod, only: d00, d50, d25 use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, modelname, spval, im, jm, & - jsta_2l, jend_2u + jsta_2l, jend_2u, ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -54,7 +55,7 @@ SUBROUTINE CALDRG(DRAGCO) ! INCLUDE/SET PARAMETERS. ! ! DECLARE VARIABLES. - REAL,intent(inout) :: DRAGCO(IM,jsta_2l:jend_2u) + REAL,intent(inout) :: DRAGCO(ista_2l:iend_2u,jsta_2l:jend_2u) INTEGER IHE(JM),IHW(JM) integer I,J,LHMK,IE,IW,LMHK real UBAR,VBAR,WSPDSQ,USTRSQ,SUMU,SUMV,ULMH,VLMH,UZ0H,VZ0H @@ -66,7 +67,7 @@ SUBROUTINE CALDRG(DRAGCO) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! DRAGCO(I,J) = D00 DRAGCO(I,J) = 0.0 @@ -76,7 +77,7 @@ SUBROUTINE CALDRG(DRAGCO) IF(gridtype=='A')THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! IF (USTAR(I,J) /= SPVAL) THEN @@ -110,7 +111,7 @@ SUBROUTINE CALDRG(DRAGCO) ENDDO DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M ! ! COMPUTE A MEAN MASS POINT WIND IN THE ! FIRST ATMOSPHERIC ETA LAYER. @@ -147,7 +148,7 @@ SUBROUTINE CALDRG(DRAGCO) END DO ELSE IF(gridtype=='B')THEN DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M ! ! COMPUTE A MEAN MASS POINT WIND IN THE ! FIRST ATMOSPHERIC ETA LAYER. @@ -193,7 +194,7 @@ SUBROUTINE CALDRG(DRAGCO) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND DRAGCO(I,J) = SPVAL ENDDO ENDDO diff --git a/sorc/ncep_post.fd/CALDWP.f b/sorc/ncep_post.fd/CALDWP.f index aa2405e05..d82714d41 100644 --- a/sorc/ncep_post.fd/CALDWP.f +++ b/sorc/ncep_post.fd/CALDWP.f @@ -13,6 +13,7 @@ !! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D !! 00-01-04 JIM TUCCILLO - MPI VERSION !! 21-07-23 Wen Meng - Retrict computation from undefined points +!! 21-09-02 Bo Cui - Decompose UPP in X directi !! !! USAGE: CALL CALDWP(P1D,Q1D,TDWP,T1D) !! INPUT ARGUMENT LIST: @@ -43,16 +44,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 ! !**************************************************************************** @@ -62,7 +63,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) Date: Fri, 17 Sep 2021 19:23:49 +0000 Subject: [PATCH 32/77] 20210917 Jesse Meng remove 4 legacy files --- sorc/ncep_post.fd/EXCH2.f | 72 - sorc/ncep_post.fd/INITPOST_GFS_NEMS.f | 3265 ------------------------ sorc/ncep_post.fd/INITPOST_GFS_SIGIO.f | 3062 ---------------------- sorc/ncep_post.fd/SLP_NMM.f | 411 --- 4 files changed, 6810 deletions(-) delete mode 100644 sorc/ncep_post.fd/EXCH2.f delete mode 100644 sorc/ncep_post.fd/INITPOST_GFS_NEMS.f delete mode 100644 sorc/ncep_post.fd/INITPOST_GFS_SIGIO.f delete mode 100644 sorc/ncep_post.fd/SLP_NMM.f 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/INITPOST_GFS_NEMS.f b/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f deleted file mode 100644 index 7111fb628..000000000 --- a/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f +++ /dev/null @@ -1,3265 +0,0 @@ -!> @file -! . . . -!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN -!! PRGRMMR: Hui-Ya Chuang DATE: 2007-03-01 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF GFS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 2011-02-07 Jun Wang add grib2 option -!! 2011-12-14 Sarah Lu add aer option -!! 2012-01-07 Sarah Lu compute air density -!! 2012-12-22 Sarah Lu add aerosol zerout option -!! 2015-03-16 S. Moorthi adding gocart_on option -!! 2015-03-18 S. Moorthi Optimization including threading -!! 2015-08-17 S. Moorthi Add TKE for NEMS/GSM -!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INIT -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D, & - iostatusAER,nfile,ffile,rfile) -! SUBROUTINE INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,nfile,ffile) - - - use vrbls4d, only: dust, SALT, SUSO, SOOT, WASO - use vrbls3d, only: t, q, uh, vh, pmid, pint, alpint, dpres, zint, zmid, o3, & - qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, & - tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, & - o3vdiff, o3prod, o3tndy, mwpv, unknown, vdiffzacce, zgdrag,cnvctummixing, & - vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, & - cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp - use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, & - cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, & - tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, radot, sigt4, & - cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, & - islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, & - bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, & - rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, & - snopcx, sfcux, sfcvx, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, & - smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, & - uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, & - ptoph, pboth, pblcfr, ttoph, runoff, maxtshltr, mintshltr, maxrhshltr, & - minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, & - cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa, & - u10h,v10h - use soil, only: sldpth, sh2o, smc, stc - use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice -! use kinds, only: i_llong - use nemsio_module, only: nemsio_gfile, nemsio_getfilehead, nemsio_getheadvar, nemsio_close - use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, & - eps => con_eps, epsm1 => con_epsm1 - use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa - use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, & - ttblq, rdpq, rdtheq, stheq, the0q, the0 - use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, & - ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, & - jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,& - ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, & - jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, & - nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp - use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, & - dxval, dyval, truelat2, truelat1, psmapf, cenlat - use rqstfld_mod, only: igds, avbl, iq, is - use upp_physics, only: fpvsnew -! use wrf_io_flags_mod, only: ! Do we need this? -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! - type(nemsio_gfile),intent(inout) :: nfile,ffile,rfile -! -! INCLUDE/SET PARAMETERS. -! - INCLUDE "mpif.h" - -! integer,parameter:: MAXPTS=1000000 ! max im*jm points -! -! real,parameter:: con_g =9.80665e+0! gravity -! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O -! real,parameter:: con_rd =2.8705e+2 ! gas constant air -! real,parameter:: con_fvirt =con_rv/con_rd-1. -! real,parameter:: con_eps =con_rd/con_rv -! real,parameter:: con_epsm1 =con_rd/con_rv-1 -! -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - - real, parameter :: gravi = 1.0/grav - integer,intent(in) :: NREC,iostatusFlux,iostatusD3D,iostatusAER - character(len=20) :: VarName, VcoordName - integer :: Status - character startdate*19,SysDepInfo*80,cgar*1 - character startdate2(19)*4 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL - logical, parameter :: debugprint = .false., zerout = .false. -! logical, parameter :: debugprint = .true., zerout = .false. - CHARACTER*32 LABEL - CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC - CHARACTER*4 RESTHR - CHARACTER FNAME*255,ENVAR*50 - INTEGER IDATE(8),JDATE(8),JPDS(200),JGDS(200),KPDS(200),KGDS(200) -! LOGICAL*1 LB(IM,JM) -! -! INCLUDE COMMON BLOCKS. -! -! DECLARE VARIABLES. -! -! REAL fhour - integer nfhour ! forecast hour from nems io file - REAL RINC(5) - - REAL DUMMY(IM,JM), DUMMY2(IM,JM) - real, allocatable :: fi(:,:,:) -!jw - integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, & - I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, & - impf,jmpf,nframed2,iunitd3d,ierr,idum,iret - real TSTART,TLMH,TSPH,ES,FACT,soilayert,soilayerb,zhour,dum, & - tvll,pmll,tv - - character*8, allocatable :: recname(:) - character*16,allocatable :: reclevtyp(:) - integer, allocatable :: reclev(:) - real, allocatable :: glat1d(:), glon1d(:), qstl(:) - real, allocatable :: wrk1(:,:), wrk2(:,:) - real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), & - qs2d(:,:), cw2d(:,:), cfr2d(:,:) - real(kind=4),allocatable :: vcoord4(:,:,:) - real, dimension(lm+1) :: ak5, bk5 - real*8, allocatable :: pm2d(:,:), pi2d(:,:) - - real buf(im,jsta_2l:jend_2u) - -! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & -! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) - - real LAT, isa, jsa -! REAL, PARAMETER :: QMIN = 1.E-15 - -! DATA BLANK/' '/ -! -!*********************************************************************** -! START INIT HERE. -! - WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NEMS' - WRITE(6,*)'me=',me,'LMV=',size(LMV,1),size(LMV,2),'LMH=', & - size(LMH,1),size(LMH,2),'jsta_2l=',jsta_2l,'jend_2u=', & - jend_2u,'im=',im -! - isa = im / 2 - jsa = (jsta+jend) / 2 - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - buf(i,j) = spval - enddo - enddo -! -! STEP 1. READ MODEL OUTPUT FILE -! -! -!*** -! -! LMH and LMV always = LM for sigma-type vert coord - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i = 1, im - LMV(i,j) = lm - LMH(i,j) = lm - end do - end do - -! HTM VTM all 1 for sigma-type vert coord - -!$omp parallel do private(i,j,l) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - HTM (i,j,l) = 1.0 - VTM (i,j,l) = 1.0 - end do - end do - end do -! -! how do I get the filename? -! fileName = '/ptmp/wx20mb/wrfout_01_030500' -! DateStr = '2002-03-05_18:00:00' -! how do I get the filename? -! call ext_int_ioinit(SysDepInfo,Status) -! print*,'called ioinit', Status -! call ext_int_open_for_read( trim(fileName), 0, 0, " ", -! & DataHandle, Status) -! print*,'called open for read', Status -! if ( Status /= 0 ) then -! print*,'error opening ',fileName, ' Status = ', Status ; stop -! endif -! get date/time info -! this routine will get the next time from the file, not using it -! print *,'DateStr before calling ext_int_get_next_time=',DateStr -! call ext_int_get_next_time(DataHandle, DateStr, Status) -! print *,'DateStri,Status,DataHandle = ',DateStr,Status,DataHandle - -! The end j row is going to be jend_2u for all variables except for V. - - JS = JSTA_2L - JE = JEND_2U - -! get start date - if (me == 0)then - print*,'nrec=',nrec - allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - allocate(glat1d(im*jm),glon1d(im*jm)) - allocate(vcoord4(lm+1,3,2)) - call nemsio_getfilehead(nfile,iret=iret & - ,idate=idate(1:7),nfhour=nfhour,recname=recname & - ,reclevtyp=reclevtyp,reclev=reclev,lat=glat1d & - ,lon=glon1d,nframe=nframe,vcoord=vcoord4) - if(iret/=0)print*,'error getting idate,nfhour' - print *,'latstar1=',glat1d(1),glat1d(im*jm) -! print *,'printing an inventory of GFS nemsio file' -! do i=1,nrec -! print *,'recname=',(trim(recname(i))) -! print *,'reclevtyp=',(trim(reclevtyp(i))) -! print *,'reclev=',(reclev(i)) -! end do -! deallocate (recname,reclevtyp,reclev) - -! call nemsio_getfilehead(ffile,nrec=idum) -! print*,'nrec for flux file = ',idum -! allocate(recname(idum),reclevtyp(idum),reclev(idum)) -! call nemsio_getfilehead(ffile,iret=iret, & -! recname=recname,reclevtyp=reclevtyp,reclev=reclev) -! do i=1,idum -! print *,'recname=',(trim(recname(i))) -! print *,'reclevtyp=',(trim(reclevtyp(i))) -! print *,'reclev=',(reclev(i)) -! end do - -!$omp parallel do private(i,j) - do j=1,jm - do i=1,im - dummy(i,j) = glat1d((j-1)*im+i) - dummy2(i,j) = glon1d((j-1)*im+i) - end do - end do -! - if (hyb_sigp) then - do l=1,lm+1 - ak5(l) = vcoord4(l,1,1) - bk5(l) = vcoord4(l,2,1) - enddo - endif -! - deallocate(recname,reclevtyp,reclev,glat1d,glon1d,vcoord4) -! can't get idate and fhour, specify them for now -! idate(4)=2006 -! idate(2)=9 -! idate(3)=16 -! idate(1)=0 -! fhour=6.0 - print*,'idate before broadcast = ',(idate(i),i=1,7) - end if - call mpi_bcast(idate(1), 7, MPI_INTEGER, 0, mpi_comm_comp, iret) - call mpi_bcast(nfhour, 1, MPI_INTEGER, 0, mpi_comm_comp, iret) - call mpi_bcast(nframe, 1, MPI_INTEGER, 0, mpi_comm_comp, iret) - print*,'idate after broadcast = ',(idate(i),i=1,4) - print*,'nfhour = ',nfhour - - if (hyb_sigp) then - call mpi_bcast(ak5, lm+1, MPI_REAL, 0, mpi_comm_comp, iret) - call mpi_bcast(bk5, lm+1, MPI_REAL, 0, mpi_comm_comp, iret) - endif - if (me == 0) print *,' ak5=',ak5 - if (me == 0) print *,' bk5=',bk5 - -! sample print point - ii = im/2 - jj = jm/2 - call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & - ,gdlat(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,ierr) - call mpi_scatterv(dummy2(1,1),icnt,idsp,mpi_real & - ,gdlon(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,ierr) - - print *,'before call EXCH,mype=',me,'max(gdlat)=',maxval(gdlat), & - 'max(gdlon)=', maxval(gdlon) - CALL EXCH(gdlat(1,JSTA_2L)) - print *,'after call EXCH,mype=',me - -!$omp parallel do private(i,j) - do j = jsta, jend_m - do i = 1, im-1 - DX (i,j) = ERAD*COS(GDLAT(I,J)*DTR) *(GDLON(I+1,J)-GDLON(I,J))*DTR - DY (i,j) = ERAD*(GDLAT(I,J)-GDLAT(I,J+1))*DTR ! like A*DPH -! F(I,J)=1.454441e-4*sin(gdlat(i,j)*DTR) ! 2*omeg*sin(phi) -! if (i == ii .and. j == jj) print*,'sample LATLON, DY, DY=' & -! ,i,j,GDLAT(I,J),GDLON(I,J),DX(I,J),DY(I,J) - end do - end do - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - F(I,J) = 1.454441e-4*sin(gdlat(i,j)*DTR) ! 2*omeg*sin(phi) - end do - end do - - impf = im - jmpf = jm - print*,'impf,jmpf,nframe= ',impf,jmpf,nframe - -!MEB not sure how to get these - ! waiting to read in lat lon from GFS soon -! varname='GLAT' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! GDLAT=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im -! this_length=im*(jend_2u-jsta_2l+1) -! call mpi_file_read_at(iunit,this_offset -! + ,buf,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! GDLAT=SPVAL -! else -! do j = jsta_2l, jend_2u -! do i = 1, im -! F(I,J)=1.454441e-4*sin(buf(I,J)) ! 2*omeg*sin(phi) -! GDLAT(I,J)=buf(I,J)*RTD - -! enddo -! enddo -! end if -! end if - -! varname='GLON' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! GDLON=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im -! this_length=im*(jend_2u-jsta_2l+1) -! call mpi_file_read_at(iunit,this_offset -! + ,buf,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! GDLON=SPVAL -! else -! do j = jsta_2l, jend_2u -! do i = 1, im -! GDLON(I,J)=buf(I,J)*RTD -! if(i == 409.and.j == 835)print*,'GDLAT GDLON in INITPOST=' -! + ,i,j,GDLAT(I,J),GDLON(I,J) -! enddo -! enddo -! end if -! end if - -! if(jsta<=594.and.jend>=594)print*,'gdlon(120,594)= ', -! + gdlon(120,594) - - -! iyear=idate(4)+2000 ! older gfsio only has 2 digit year - iyear = idate(1) - imn = idate(2) ! ask Jun - iday = idate(3) ! ask Jun - ihrst = idate(4) - imin = idate(5) - jdate = 0 - idate = 0 -! -! read(startdate,15)iyear,imn,iday,ihrst,imin - 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2) - print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin - print*,'processing yr mo day hr min=' & - ,idat(3),idat(1),idat(2),idat(4),idat(5) -! - idate(1) = iyear - idate(2) = imn - idate(3) = iday - idate(5) = ihrst - idate(6) = imin - SDAT(1) = imn - SDAT(2) = iday - SDAT(3) = iyear - jdate(1) = idat(3) - jdate(2) = idat(1) - jdate(3) = idat(2) - jdate(5) = idat(4) - jdate(6) = idat(5) -! - print *,' idate=',idate - print *,' jdate=',jdate -! CALL W3DIFDAT(JDATE,IDATE,2,RINC) -! ifhr=nint(rinc(2)) -! - CALL W3DIFDAT(JDATE,IDATE,0,RINC) -! - print *,' rinc=',rinc - ifhr = nint(rinc(2)+rinc(1)*24.) - print *,' ifhr=',ifhr - ifmin = nint(rinc(3)) -! if(ifhr /= nint(fhour))print*,'find wrong Grib file';stop - print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,fileName - -! GFS has the same accumulation bucket for precipitation and fluxes and it is written to header -! the header has the start hour information so post uses it to recontruct bucket - if(me==0)then - call nemsio_getheadvar(ffile,'zhour',zhour,iret=iret) - if(iret==0)then - tprec = 1.0*ifhr-zhour - tclod = tprec - trdlw = tprec - trdsw = tprec - tsrfc = tprec - tmaxmin = tprec - td3d = tprec - print*,'tprec from flux file header= ',tprec - else - print*,'Error reading accumulation bucket from flux file', & - 'header - will try to read from env variable FHZER' - CALL GETENV('FHZER',ENVAR) - read(ENVAR, '(I2)')idum - tprec = idum*1.0 - tclod = tprec - trdlw = tprec - trdsw = tprec - tsrfc = tprec - tmaxmin = tprec - td3d = tprec - print*,'TPREC from FHZER= ',tprec - end if - end if - - call mpi_bcast(tprec, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(tclod, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(trdlw, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(trdsw, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(tsrfc, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(tmaxmin,1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(td3d, 1,MPI_REAL,0,mpi_comm_comp,iret) - -! Getting tstart - tstart=0. -! VarName='TSTART' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file" -! else -! call mpi_file_read_at(iunit,file_offset(index)+5*4 -! + ,garb,1,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName," using MPIIO" -! else -! print*,VarName, ' from MPIIO READ= ',garb -! tstart=garb -! end if -! end if - print*,'tstart= ',tstart - -! Getiing restart - - RESTRT=.TRUE. ! set RESTRT as default -! call ext_int_get_dom_ti_integer(DataHandle,'RESTARTBIN',itmp -! + ,1,ioutcount,istatus) - -! IF(itmp < 1)THEN -! RESTRT=.FALSE. -! ELSE -! RESTRT=.TRUE. -! END IF - -! print*,'status for getting RESTARTBIN= ',istatus - -! print*,'Is this a restrt run? ',RESTRT - - IF(tstart > 1.0E-2)THEN - ifhr = ifhr+NINT(tstart) - rinc = 0 - idate = 0 - rinc(2) = -1.0*ifhr - call w3movdat(rinc,jdate,idate) - SDAT(1) = idate(2) - SDAT(2) = idate(3) - SDAT(3) = idate(1) - IHRST = idate(5) - print*,'new forecast hours for restrt run= ',ifhr - print*,'new start yr mo day hr min =',sdat(3),sdat(1) & - ,sdat(2),ihrst,imin - END IF - - imp_physics = 99 !set GFS mp physics to 99 for Zhao scheme - print*,'MP_PHYSICS= ',imp_physics - -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then - CALL MICROINIT(imp_physics) - end if - -! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD - VarName='IVEGSRC' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),IVEGSRC,iret) - if (iret /= 0) then - print*,VarName,' not found in file-Assigned 2 for UMD as default' - IVEGSRC=1 - end if - end if - call mpi_bcast(IVEGSRC,1,MPI_INTEGER,0,mpi_comm_comp,iret) - print*,'IVEGSRC= ',IVEGSRC - -! set novegtype based on vegetation classification - if(ivegsrc==2)then - novegtype=13 - else if(ivegsrc==1)then - novegtype=20 - else if(ivegsrc==0)then - novegtype=24 - end if - print*,'novegtype= ',novegtype - - VarName='CU_PHYSICS' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),iCU_PHYSICS,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 4 for SAS as default" - iCU_PHYSICS=4 - end if - end if - call mpi_bcast(iCU_PHYSICS,1,MPI_INTEGER,0,mpi_comm_comp,iret) - if (me == 0) print*,'CU_PHYSICS= ',iCU_PHYSICS -! waiting to retrieve lat lon infor from raw GFS output -! VarName='DX' - -! VarName='DY' - -! GFS does not need DT to compute accumulated fields, set it to one -! VarName='DT' - DT=1 -! GFS does not need truelat -! VarName='TRUELAT1' - -! VarName='TRUELAT2' - -! Specigy maptype=4 for Gaussian grid -! maptype=4 -! write(6,*) 'maptype is ', maptype -! HBM2 is most likely not in Grib message, set them to ones - HBM2=1.0 - -! try to get kgds from flux grib file and then convert to igds that is used by GRIBIT.f -! flux files are now nemsio files so comment the following lines out -! if(me == 0)then -! jpds=-1.0 -! jgds=-1.0 -! igds=0 -! call getgb(iunit,0,im_jm,0,jpds,jgds,kf & -! ,k,kpds,kgds,lb,dummy,ierr) -! if(ierr == 0)then -! call R63W72(KPDS,KGDS,JPDS,IGDS(1:18)) -! print*,'in INITPOST_GFS,IGDS for GFS= ',(IGDS(I),I=1,18) -! end if -! end if -! call mpi_bcast(igds(1),18,MPI_INTEGER,0,mpi_comm_comp,iret) -! print*,'IGDS for GFS= ',(IGDS(I),I=1,18) - -! Specigy grid type -! if(iostatusFlux==0)then - if(IGDS(4)/=0)then - maptype=IGDS(3) - else if((im/2+1)==jm)then - maptype=0 !latlon grid - else - maptype=4 ! default gaussian grid - end if - gridtype='A' - - if (me == 0) write(6,*) 'maptype and gridtype is ', maptype,gridtype - -! start retrieving data using gfsio, first land/sea mask - -! VarName='land' -! VcoordName='sfc' -! l=1 - -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! else -! -! do j = 1, jm -! do i = 1, im -! dummy(I,J)=1.0 - dummy(I,J) ! convert Grib message to 2D -! if (j == jm/2 .and. mod(i,10) == 0) -! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j) -! -! enddo -! enddo -! end if -! end if -! -! call mpi_scatterv(dummy,icnt,idsp,mpi_real -! + ,sm(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - - VcoordName='sfc' ! surface fileds - l=1 - -! start retrieving data using getgb, first land/sea mask - VarName='land' - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,sm) - -! where(sm /= spval)sm=1.0-sm ! convert to sea mask -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',sm(isa,jsa) - - -! sea ice mask using getgb - - VarName='icec' - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sice) - -! if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa) - -! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea mask=0 -! GFS flux files have land points with non-zero sea ice, per Iredell, these -! points have sea ice changed to zero, i.e., trust land mask more than sea ice -! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0 - enddo - enddo - -! Terrain height * G using nemsio - VarName='hgt' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,fis) - -! where(fis /= spval)fis=fis*grav - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (fis(i,j) /= spval) then - zint(i,j,lp1) = fis(i,j) - fis(i,j) = fis(i,j) * grav - - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',fis(isa,jsa) - -! Surface pressure using nemsio - VarName='pres' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pint(1,jsta_2l,lp1)) - -! if(debugprint)print*,'sample surface pressure = ',pint(isa,jsa,lp1 - -! -! vertical loop for Layer 3d fields -! -------------------------------- - VcoordName = 'mid layer' - - do l=1,lm - ll=lm-l+1 - -! model level T - print*,'start retrieving GFS T using nemsio' - VarName='tmp' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,t(1,jsta_2l,ll)) - -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,t(isa,jsa,ll) - -! model level q - VarName='spfh' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,q(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,q(isa,jsa,ll) - -! i model level u - VarName='ugrd' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,uh(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,uh(isa,jsa,ll) - -! model level v - VarName='vgrd' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,vh(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,vh(isa,jsa,ll) - -! model level pressure - if (.not. hyb_sigp) then - VarName='pres' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pmid(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,pmid(isa,jsa,ll) - -! GFS is on A grid and does not need PMIDV - -! dp - VarName='dpres' -! write(0,*)' bef getnemsandscatter ll=',ll,' l=',l,VarName - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dpres(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,pmid(isa,jsa,ll) - endif -! ozone mixing ratio - VarName='o3mr' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,o3(1,jsta_2l,ll)) - -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,o3(isa,jsa,ll) -! write(1000+me,*)'sample ',ll,VarName,' = ',ll,o3(isa,jsa,ll) - -! cloud water and ice mixing ratio for zhao scheme -! need to look up old eta post to derive cloud water/ice from cwm -! Zhao scheme does not produce suspended rain and snow - -!$omp parallel do private(i,j) - do j = jsta, jend - do i=1,im - qqw(i,j,ll) = 0. - qqr(i,j,ll) = 0. - qqs(i,j,ll) = 0. - qqi(i,j,ll) = 0. - enddo - enddo - - VarName='clwmr' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,cwm(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,cwm(isa,jsa,ll) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if(t(i,j,ll) < (TFRZ-15.) )then ! dividing cloud water from ice - qqi(i,j,ll) = cwm(i,j,ll) - else - qqw(i,j,ll) = cwm(i,j,ll) - end if -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample ',trim(VarName), ' after scatter= ' -! + ,i,j,ll,cwm(i,j,ll) - end do - end do -! if (iret /= 0)print*,'Error scattering array';stop - -! pressure vertical velocity - VarName='vvel' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,omga(1,jsta_2l,ll)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,omga(isa,jsa,ll) - -! With SHOC NEMS/GSM does output TKE now - VarName='tke' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,q2(1,jsta_2l,ll)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,q2(isa,jsa,ll) - - - end do ! do loop for l - -! construct interface pressure from model top (which is zero) and dp from top down PDTOP -! pdtop = spval - pt = 0. -! pd = spval ! GFS does not output PD - - ii = im/2 - jj = (jsta+jend)/2 - -!!!!! COMPUTE Z, GFS integrates Z on mid-layer instead -!!! use GFS contants to see if height becomes more aggreable to GFS pressure grib file - if (hyb_sigp) then - do l=lm,1,-1 -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - pint(i,j,l) = ak5(lm+2-l) + bk5(lm+2-l)*pint(i,j,lp1) - pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) ! for now - Moorthi - enddo - enddo - if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l) - enddo - else - do l=2,lm -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) - enddo - enddo - if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l) - end do - endif - - allocate(wrk1(im,jsta:jend),wrk2(im,jsta:jend)) - allocate(fi(im,jsta:jend,2)) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - pd(i,j) = spval ! GFS does not output PD - pint(i,j,1) = PT - alpint(i,j,lp1) = log(pint(i,j,lp1)) - wrk1(i,j) = log(PMID(I,J,LM)) - wrk2(i,j) = T(I,J,LM)*(Q(I,J,LM)*fv+1.0) - FI(I,J,1) = FIS(I,J) & - + wrk2(i,j)*rgas*(ALPINT(I,J,Lp1)-wrk1(i,j)) - ZMID(I,J,LM) = FI(I,J,1) * gravi - end do - end do - - print *,' Tprof=',t(ii,jj,:) - print *,' Qprof=',q(ii,jj,:) - -! SECOND, INTEGRATE HEIGHT HYDROSTATICLY, GFS integrate height on mid-layer - - DO L=LM,2,-1 ! omit computing model top height because it's infinity - ll = l - 1 -! write(0,*)' me=',me,'ll=',ll,' gravi=',gravi,rgas,' fv=',fv -!$omp parallel do private(i,j,tvll,pmll,fact) - do j = jsta, jend -! write(0,*)' j=',j,' me=',me - do i = 1, im - alpint(i,j,l) = log(pint(i,j,l)) - tvll = T(I,J,LL)*(Q(I,J,LL)*fv+1.0) - pmll = log(PMID(I,J,LL)) - -! if (me == 0 .and. i == ii .and. j == jj ) print*,'L ZINT= ',l,' tvll =', tvll, & -! ' pmll=',pmll,' wrk2=',wrk2(i,j),' wrk1=',wrk1(i,j),' fi1=',fi(i,j,1), & -! ' T=',T(i,j,LL),' Q=',Q(i,j,ll) - - FI(I,J,2) = FI(I,J,1) + (0.5*rgas)*(wrk2(i,j)+tvll) & - * (wrk1(i,j)-pmll) - ZMID(I,J,LL) = FI(I,J,2) * gravi -! - FACT = (ALPINT(I,J,L)-wrk1(i,j)) / (pmll-wrk1(i,j)) - ZINT(I,J,L) = ZMID(I,J,L) + (ZMID(I,J,LL)-ZMID(I,J,L)) * FACT - FI(I,J,1) = FI(I,J,2) - wrk1(i,J) = pmll - wrk2(i,j) = tvll -! if (me == 0 .and. i == ii .and. j == jj ) print*,'L ZINT= ',l,zint(ii,jj,l), & -! 'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)),'pmid(l-1)=', & -! LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L),'zmid(l-1)=',ZMID(Ii,Jj,L-1) - ENDDO - ENDDO - - if (me == 0) print*,'L ZINT= ',l,zint(ii,jj,l), & - 'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)),'pmid(l-1)=', & - LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L),'zmid(l-1)=',ZMID(Ii,Jj,L-1) - ENDDO - deallocate(wrk1,wrk2,fi) - - - if (gocart_on) then - -! GFS output dust in nemsio (GOCART) - do n=1,nbin_du - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - dust(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! DUST = SPVAL - VarName='du001' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,1) - end do ! do loop for l - - VarName='du002' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,2)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,2) - end do ! do loop for l - - VarName='du003' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,3)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,3) - end do ! do loop for l - - VarName='du004' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,4)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,4) - end do ! do loop for l - - VarName='du005' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,5)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,5) - end do ! do loop for l -! -! GFS output sea salt in nemsio (GOCART) - do n=1,nbin_ss - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - salt(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! SALT = SPVAL - VarName='ss001' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,1) - end do ! do loop for l - - VarName='ss002' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,2)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,2) - end do ! do loop for l - - VarName='ss003' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,3)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,3) - end do ! do loop for l - - VarName='ss004' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,4)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,4) - end do ! do loop for l - - VarName='ss005' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,5)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,5) - end do ! do loop for l - -! GFS output black carbon in nemsio (GOCART) - do n=1,nbin_oc - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - soot(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! SOOT = SPVAL - VarName='bcphobic' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,soot(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,soot(isa,jsa,ll,1) - end do ! do loop for l - - VarName='bcphilic' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,soot(1,jsta_2l,ll,2)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,soot(isa,jsa,ll,2) - end do ! do loop for l - -! GFS output organic carbon in nemsio (GOCART) - do n=1,nbin_oc - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - waso(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! WASO = SPVAL - VarName='ocphobic' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,waso(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,waso(isa,jsa,ll,1) - end do ! do loop for l - - VarName='ocphilic' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,waso(1,jsta_2l,ll,2)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,waso(isa,jsa,ll,2) - end do ! do loop for l - -! GFS output sulfate in nemsio (GOCART) - do n=1,nbin_su - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - suso(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! SUSO = SPVAL - VarName='so4' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,suso(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,suso(isa,jsa,ll,1) - end do ! do loop for l - - -! -- compute air density RHOMID and remove negative tracer values - do l=1,lm -!$omp parallel do private(i,j,n,tv) - do j=jsta,jend - do i=1,im - - TV = T(I,J,L) * (H1+D608*MAX(Q(I,J,L),QMIN)) - RHOMID(I,J,L) = PMID(I,J,L) / (RD*TV) - do n = 1, NBIN_DU - IF ( dust(i,j,l,n) < SPVAL) THEN - DUST(i,j,l,n) = MAX(DUST(i,j,l,n), 0.0) - ENDIF - enddo - do n = 1, NBIN_SS - IF ( salt(i,j,l,n) < SPVAL) THEN - SALT(i,j,l,n) = MAX(SALT(i,j,l,n), 0.0) - ENDIF - enddo - do n = 1, NBIN_OC - IF ( waso(i,j,l,n) < SPVAL) THEN - WASO(i,j,l,n) = MAX(WASO(i,j,l,n), 0.0) - ENDIF - enddo - do n = 1, NBIN_BC - IF ( soot(i,j,l,n) < SPVAL) THEN - SOOT(i,j,l,n) = MAX(SOOT(i,j,l,n), 0.0) - ENDIF - enddo - do n = 1, NBIN_SU - IF ( suso(i,j,l,n) < SPVAL) THEN - SUSO(i,j,l,n) = MAX(SUSO(i,j,l,n), 0.0) - ENDIF - enddo - - end do - end do - end do - endif ! endif for gocart_on -! - -! PBL height using nemsio - VarName='hpbl' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pblh) -! if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa) - -! frictional velocity using nemsio - VarName='fricv' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ustar) -! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa) - -! roughness length using getgb - VarName='sfcr' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,z0) -! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa) - -! surface potential T using getgb - VarName='tmp' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ths) - -! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (ths(i,j) /= spval) then -! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) - ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa - endif - QS(i,j) = SPVAL ! GFS does not have surface specific humidity - twbs(i,j) = SPVAL ! GFS does not have inst sensible heat flux - qwbs(i,j) = SPVAL ! GFS does not have inst latent heat flux - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa) - - -! GFS does not have time step and physics time step, make up ones since they -! are not really used anyway - NPHS=2. - DT=80. - DTQ2 = DT * NPHS !MEB need to get physics DT - TSPH = 3600./DT !MEB need to get DT -! All GFS time-averaged quantities are in 6 hour bucket -! TPREC=6.0 - -! convective precip in m per physics time step using gfsio -! VarName='cprat' -! VcoordName='sfc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! else -! do j = 1, jm -! do i = 1, im -! dummy(I,J)= dummy(i,j)*dtq2/1000. ! convert to m -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j) -! enddo -! enddo -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + , avgcprate(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! convective precip in m per physics time step using getgb - VarName='cprat' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgcprate) -! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001) - cprate(i,j) = avgcprate(i,j) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa) - -! print*,'maxval CPRATE: ', maxval(CPRATE) - -! precip rate in m per physics time step using getgb - VarName='prate' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgprec) -! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgprec(i,j) /= spval) avgprec(i,j) = avgprec(i,j) * (dtq2*0.001) - enddo - enddo - -! if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa) - - prec=avgprec !set avg cprate to inst one to derive other fields - -! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f - - -! inst snow water eqivalent using nemsio - VarName='weasd' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sno) -! if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa) - -! snow depth in mm using nemsio - VarName='snod' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,si) -! where(si /= spval)si=si*1000. ! convert to mm -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 - CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency - lspa(i,j) = spval ! GFS does not have similated precip - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - Q10(i,j) = SPVAL ! GFS does not have 10 m humidity - ALBASE(i,j) = SPVAL ! GFS does not have snow free albedo - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa) - -!!$omp parallel do private(i,j,l) -! do l=1,lm -! do j=jsta,jend -! do i=1,im -! Q2(i,j,l) = SPVAL ! GFS does not have TKE because it uses MRF scheme -! ! GFS does not have surface exchange coeff -! enddo -! enddo -! enddo - -! 2m T using nemsio - VarName='tmp' - VcoordName='2 m above gnd' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,tshltr) -! if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) - -! GFS does not have 2m pres, estimate it, also convert t to theta - Do j=jsta,jend - Do i=1,im - PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample 2m T and P after scatter= ' -! + ,i,j,tshltr(i,j),pshltr(i,j) - end do - end do - -! 2m specific humidity using gfsio -! VarName='spfh' -! VcoordName='2m above gnc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + ,qshltr(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! 2m specific humidity using nemsio - VarName='spfh' - VcoordName='2 m above gnd' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,qshltr) -! if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa) - - -! mid day avg albedo in fraction using gfsio -! VarName='albdo' -! VcoordName='sfc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! else -! do j = 1, jm -! do i = 1, im -! dummy(I,J)= dummy(i,j)/100. ! convert to fraction -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j) -! enddo -! enddo -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + ,avgalbedo(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! mid day avg albedo in fraction using nemsio - VarName='albdo' - VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgalbedo) -! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) - -! time averaged column cloud fractionusing nemsio - VarName='tcdc' - VcoordName='atmos col' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgtcdc) -! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa) - -! GFS probably does not use zenith angle -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - Czen(i,j) = spval - CZMEAN(i,j) = SPVAL - enddo - enddo - -! maximum snow albedo in fraction using nemsio - VarName='mxsalb' - VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,mxsnal) -! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - radot(i,j) = spval ! GFS does not have inst surface outgoing longwave - enddo - enddo - -! GFS probably does not use sigt4, set it to sig*t^4 -!$omp parallel do private(i,j,tlmh) - Do j=jsta,jend - Do i=1,im - TLMH = T(I,J,LM) * T(I,J,LM) - Sigt4(i,j) = 5.67E-8 * TLMH * TLMH - End do - End do - -! TG is not used, skip it for now - -! will retrive f_ice when GFS switches to Ferrier scheme -! varname='F_ICE' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! F_ice=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm -! this_length=im*(jend_2u-jsta_2l+1)*lm -! call mpi_file_read_at(iunit,this_offset -! + ,buf3d,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! F_ice=SPVAL -! else -! do l = 1, lm -! ll=lm-l+1 -! do j = jsta_2l, jend_2u -! do i = 1, im -! F_ice( i, j, l ) = buf3d ( i, ll, j ) -! if(i == im/2.and.j == (jsta+jend)/2)print*,'sample F_ice= ', -! + i,j,l,F_ice( i, j, l ) -! end do -! end do -! end do -! end if -! end if - -! varname='F_RAIN' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! F_rain=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm -! this_length=im*(jend_2u-jsta_2l+1)*lm -! call mpi_file_read_at(iunit,this_offset -! + ,buf3d,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! F_rain=SPVAL -! else -! do l = 1, lm -! ll=lm-l+1 -! do j = jsta_2l, jend_2u -! do i = 1, im -! F_rain( i, j, l ) = buf3d ( i, ll, j ) -! if(i == im/2.and.j == (jsta+jend)/2)print*,'sample F_rain= ', -! + i,j,l,F_rain( i, j, l ) -! end do -! end do -! end do -! end if -! end if - -! varname='F_RIMEF' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! F_RimeF=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm -! this_length=im*(jend_2u-jsta_2l+1)*lm -! call mpi_file_read_at(iunit,this_offset -! + ,buf3d,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! F_RimeF=SPVAL -! else -! do l = 1, lm -! ll=lm-l+1 -! do j = jsta_2l, jend_2u -! do i = 1, im -! F_RimeF( i, j, l ) = buf3d ( i, ll, j ) -! if(i == im/2.and.j == (jsta+jend)/2)print*, -! + 'sample F_RimeF= ',i,j,l,F_RimeF( i, j, l ) -! end do -! end do -! end do -! end if -! end if - -! GFS does not have model level cloud fraction -> derive cloud fraction -! CFR=SPVAL -! allocate(qstl(lm)) -! print*,'start deriving cloud fraction' - -! do j=jsta,jend -! do i=1,im -! do l=1,lm -! if(i==im/2.and.j==jsta)print*,'sample T=',t(i,j,l) -! es=fpvsnew(t(i,j,l)) -! if(i==im/2.and.j==jsta)print*,'sample ES=',es -! es=min(es,pmid(i,j,l)) -! if(i==im/2.and.j==jsta)print*,'sample ES=',es -! qstl(l)=con_eps*es/(pmid(i,j,l)+con_epsm1*es) !saturation q for GFS -! end do -! call progcld1 -!................................... - -! --- inputs: -! & ( pmid(i,j,1:lm)/100.,pint(i,j,1:lm+1)/100., -! & t(i,j,1:lm),q(i,j,1:lm),qstl,cwm(i,j,1:lm), -! & gdlat(i,j),gdlon(i,j), -! & 1, lm, lm+1, 0, -! --- outputs: -! & cfr(i,j,1:lm) -! & ) -! do l=1,lm -! cfr(i,j,l)=cldtot(l) -! end do -! end do -! end do - allocate(p2d(im,lm),t2d(im,lm),q2d(im,lm),cw2d(im,lm), & - qs2d(im,lm),cfr2d(im,lm)) - do j=jsta,jend -!$omp parallel do private(i,k,es) - do k=1,lm - do i=1,im - p2d(i,k) = pmid(i,j,k)*0.01 - t2d(i,k) = t(i,j,k) - q2d(i,k) = q(i,j,k) - cw2d(i,k) = cwm(i,j,k) - es = min(fpvsnew(t(i,j,k)),pmid(i,j,k)) - qs2d(i,k) = eps*es/(pmid(i,j,k)+epsm1*es)!saturation q for GFS - enddo - enddo - call progcld1 & -!................................... -! --- inputs: - ( p2d,t2d,q2d,qs2d,cw2d,im,lm,0, & -! --- outputs: - cfr2d & - ) -!$omp parallel do private(i,k) - do k=1,lm - do i=1,im - cfr(i,j,k) = cfr2d(i,k) - enddo - end do - end do - deallocate(p2d,t2d,q2d,qs2d,cw2d,cfr2d) - - -! ask murthy if there is snow rate in GFS -! varname='SR' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! SR=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im -! this_length=im*(jend_2u-jsta_2l+1) -! call mpi_file_read_at(iunit,this_offset -! + ,sr,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! SR=SPVAL -! end if -! end if - -! GFS does not have inst cloud fraction for high, middle, and low cloud -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - cfrach(i,j) = spval - cfracl(i,j) = spval - cfracm(i,j) = spval - enddo - enddo - -! ave high cloud fraction using nemsio - VarName='tcdc' - VcoordName='high cld lay' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgcfrach) -! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa) - -! ave low cloud fraction using nemsio - VarName='tcdc' - VcoordName='low cld lay' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgcfracl) -! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa) - -! ave middle cloud fraction using nemsio - VarName='tcdc' - VcoordName='mid cld lay' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgcfracm) -! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa) - -! inst convective cloud fraction using nemsio - VarName='tcdc' - VcoordName='convect-cld laye' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,cnvcfr) -! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa) - -! slope type using nemsio - VarName='sltyp' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,buf) -! where(buf /= spval)islope=nint(buf) -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - islope(i,j) = nint(buf(i,j)) - else - islope(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa) - -! plant canopy sfc wtr in m using nemsio - VarName='cnwat' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,cmc) -! where(cmc /= spval)cmc=cmc/1000. ! convert from kg*m^2 to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - grnflx(i,j) = spval ! GFS does not have inst ground heat flux - enddo - enddo - -! GFS does not have snow cover yet -! VarName='gflux' -! VcoordName='sfc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + , pctsno(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! asuume tg3 in GFS is the same as soiltb in wrf nmm. It's in sfc file, will -! be able to read it when it merges to gfs io -! soiltb is not being put out, comment it out -! VarName='tg3' -! VcoordName='sfc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! end if -! end if -! call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & -! , soiltb(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! vegetation fraction in fraction. using nemsio - VarName='veg' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,vegfrc) -! where(vegfrc /= spval) -! vegfrc=vegfrc/100. ! convert to fraction -! elsewhere (vegfrc == spval) -! vegfrc=0. ! set to zero to be reasonable input for crtm -! end where -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (vegfrc(i,j) /= spval) then - vegfrc(i,j) = vegfrc(i,j) * 0.01 - else - vegfrc(i,j) = 0.0 - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa) - -! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam - - SLDPTH(1) = 0.10 - SLDPTH(2) = 0.3 - SLDPTH(3) = 0.6 - SLDPTH(4) = 1.0 - -! liquid volumetric soil mpisture in fraction using nemsio - VarName='soill' - VcoordName='0-10 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sh2o(1,jsta_2l,1)) -! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1) - - VarName='soill' - VcoordName='10-40 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sh2o(1,jsta_2l,2)) -! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2) - - VarName='soill' - VcoordName='40-100 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sh2o(1,jsta_2l,3)) -! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3) - - VarName='soill' - VcoordName='100-200 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sh2o(1,jsta_2l,4)) -! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4) - -! volumetric soil moisture using nemsio - VarName='soilw' - VcoordName='0-10 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smc(1,jsta_2l,1)) -! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1) - - VarName='soilw' - VcoordName='10-40 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smc(1,jsta_2l,2)) -! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2) - - VarName='soilw' - VcoordName='40-100 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smc(1,jsta_2l,3)) -! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3) - - VarName='soilw' - VcoordName='100-200 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smc(1,jsta_2l,4)) -! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4) - -! soil temperature using nemsio - VarName='tmp' - VcoordName='0-10 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,stc(1,jsta_2l,1)) -! if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1) - - VarName='tmp' - VcoordName='10-40 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,stc(1,jsta_2l,2)) -! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2) - - VarName='tmp' - VcoordName='40-100 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,stc(1,jsta_2l,3)) -! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3) - - VarName='tmp' - VcoordName='100-200 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,stc(1,jsta_2l,4)) -! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 - ncfrcv(i,j) = 1.0 - acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 - ncfrst(i,j) = 1.0 - ssroff(i,j) = spval ! GFS does not have storm runoff - bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF - rlwin(i,j) = spval ! GFS does not have inst incoming sfc longwave - rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave - enddo - enddo -! trdlw(i,j) = 6.0 - ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1 - -! time averaged incoming sfc longwave using nemsio - VarName='dlwrf' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,alwin) - -! time averaged outgoing sfc longwave using gfsio - VarName='ulwrf' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,alwout) -! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa) - -! time averaged outgoing model top longwave using gfsio - VarName='ulwrf' - VcoordName='nom. top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,alwtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - rswin(i,j) = spval ! GFS does not have inst incoming sfc shortwave - rswinc(i,j) = spval ! GFS does not have inst incoming clear sky sfc shortwave - rswout(i,j) = spval ! GFS does not have inst outgoing sfc shortwave - enddo - enddo - -! GFS incoming sfc longwave has been averaged, set ARDLW to 1 - ardsw=1.0 -! trdsw=6.0 - -! time averaged incoming sfc shortwave using gfsio - VarName='dswrf' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,aswin) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa) - -! time averaged incoming sfc uv-b using getgb - VarName='duvb' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,auvbin) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa) - -! time averaged incoming sfc clear sky uv-b using getgb - VarName='cduvb' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,auvbinc) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa) - -! time averaged outgoing sfc shortwave using gfsio - VarName='uswrf' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,aswout) -! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa) - -! time averaged model top incoming shortwave - VarName='dswrf' - VcoordName='nom. top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,aswintoa) - -! time averaged model top outgoing shortwave - VarName='uswrf' - VcoordName='nom. top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,aswtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa) - -! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux -! has reversed sign convention using gfsio - VarName='shtfl' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sfcshx) -! where (sfcshx /= spval)sfcshx=-sfcshx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa) - -! GFS surface flux has been averaged, set ASRFC to 1 - asrfc=1.0 -! tsrfc=6.0 - -! time averaged surface latent heat flux, multiplied by -1 because wrf model flux -! has reversed sign vonvention using gfsio - VarName='lhtfl' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sfclhx) -! where (sfclhx /= spval)sfclhx=-sfclhx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa) - -! time averaged ground heat flux using nemsio - VarName='gflux' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,subshx) -! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa) - -! time averaged zonal momentum flux using gfsio - VarName='uflx' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sfcux) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa) - -! time averaged meridional momentum flux using nemsio - VarName='vflx' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sfcvx) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - snopcx(i,j) =spval ! GFS does not have snow phase change heat flux - sfcuvx(i,j) = spval ! GFS does not use total momentum flux - enddo - enddo - -! time averaged zonal gravity wave stress using nemsio - VarName='u-gwd' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,gtaux) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa) - -! time averaged meridional gravity wave stress using getgb - VarName='v-gwd' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,gtauy) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa) - -! time averaged accumulated potential evaporation - VarName='pevpr' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,potevp) -! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa) - - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im -! GFS does not have temperature tendency due to long wave radiation - rlwtt(i,j,l) = spval -! GFS does not have temperature tendency due to short wave radiation - rswtt(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from convection - tcucn(i,j,l) = spval - tcucns(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from grid scale - train(i,j,l) = spval - enddo - enddo - enddo - -! set avrain to 1 - avrain=1.0 - avcnvc=1.0 - theat=6.0 ! just in case GFS decides to output T tendency - -! 10 m u using nemsio - VarName='ugrd' - VcoordName='10 m above gnd' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,u10) -! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa) - do j=jsta,jend - do i=1,im - u10h(i,j)=u10(i,j) - end do - end do - -! 10 m v using gfsio - VarName='vgrd' - VcoordName='10 m above gnd' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,v10) - do j=jsta,jend - do i=1,im - v10h(i,j)=v10(i,j) - end do - end do -! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa) - -! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='vgtyp' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,buf) -! where (buf /= spval) -! ivgtyp=nint(buf) -! elsewhere -! ivgtyp=0 !need to feed reasonable value to crtm -! end where -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - ivgtyp(i,j) = nint(buf(i,j)) - else - ivgtyp(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa) - -! soil type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='sotyp' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,buf) -! where (buf /= spval) -! isltyp=nint(buf) -! elsewhere -! isltyp=0 !need to feed reasonable value to crtm -! end where -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - isltyp(i,j) = nint(buf(i,j)) - else - isltyp(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - smstav(i,j) = spval ! GFS does not have soil moisture availability - smstot(i,j) = spval ! GFS does not have total soil moisture - sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation - sfcexc(i,j) = spval ! GFS does not have surface exchange coefficient - acsnow(i,j) = spval ! GFS does not have averaged accumulated snow - acsnom(i,j) = spval ! GFS does not have snow melt - sst(i,j) = spval ! GFS does not have sst???? - thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute - qz0(i,j) = spval ! GFS does not output humidity at roughness length - uz0(i,j) = spval ! GFS does not output u at roughness length - vz0(i,j) = spval ! GFS does not output humidity at roughness length - enddo - enddo - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - EL_PBL(i,j,l) = spval ! GFS does not have mixing length - exch_h(i,j,l) = spval ! GFS does not output exchange coefficient - enddo - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa) - -! retrieve inst convective cloud top, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index - VarName='pres' - VcoordName='convect-cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ptop) -! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - htop(i,j) = spval - if(ptop(i,j) <= 0.0) ptop(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im - if(ptop(i,j) < spval)then - do l=1,lm - if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j) = l -! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', & -! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j) - exit - end if - end do - end if - end do - end do - -! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index - VarName='pres' - VcoordName='convect-cld bot' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pbot) -! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - hbot(i,j) = spval - if(pbot(i,j) <= 0.0) pbot(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im -! if(.not.lb(i,j))print*,'false bitmask for pbot at ' -! + ,i,j,pbot(i,j) - if(pbot(i,j) < spval)then - do l=lm,1,-1 - if(pbot(i,j) >= pmid(i,j,l)) then - hbot(i,j) = l -! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', & -! pbot(i,j),pmid(i,j,l),hbot(i,j) - exit - end if - end do - end if - end do - end do - -! retrieve time averaged low cloud top pressure using nemsio - VarName='pres' - VcoordName='low cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ptopl) -! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa) - -! retrieve time averaged low cloud bottom pressure using nemsio - VarName='pres' - VcoordName='low cld bot' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pbotl) -! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa) - -! retrieve time averaged low cloud top temperature using nemsio - VarName='tmp' - VcoordName='low cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,Ttopl) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa) - -! retrieve time averaged middle cloud top pressure using nemsio - VarName='pres' - VcoordName='mid cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ptopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa) - -! retrieve time averaged middle cloud bottom pressure using nemsio - VarName='pres' - VcoordName='mid cld bot' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pbotm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa) - -! retrieve time averaged middle cloud top temperature using nemsio - VarName='tmp' - VcoordName='mid cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,Ttopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa) - -! retrieve time averaged high cloud top pressure using nemsio ********* - VarName='pres' - VcoordName='high cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ptoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa) - -! retrieve time averaged high cloud bottom pressure using nemsio - VarName='pres' - VcoordName='high cld bot' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pboth) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa) - -! retrieve time averaged high cloud top temperature using nemsio - VarName='tmp' - VcoordName='high cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,Ttoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa) - -! retrieve boundary layer cloud cover using nemsio - VarName='tcdc' - VcoordName='bndary-layer cld' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pblcfr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa) -! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01 - enddo - enddo - -! retrieve cloud work function using nemsio - VarName='cwork' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,cldwork) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa) - -! retrieve water runoff using nemsio - VarName='watr' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,runoff) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa) - -! retrieve shelter max temperature using nemsio - VarName='tmax' - VcoordName='2 m above gnd' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,maxtshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,maxtshltr(isa,jsa) - -! retrieve shelter max temperature using nemsio - VarName='tmin' - VcoordName='2 m above gnd' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,mintshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & -! 1,mintshltr(im/2,(jsta+jend)/2) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - MAXRHSHLTR(i,j) = SPVAL - MINRHSHLTR(i,j) = SPVAL - enddo - enddo - -! retrieve ice thickness using nemsio - VarName='icetk' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dzice) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa) - -! retrieve wilting point using nemsio - VarName='wilt' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smcwlt) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa) - -! retrieve sunshine duration using nemsio - VarName='sunsd' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,suntime) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,suntime(isa,jsa) - -! retrieve field capacity using nemsio - VarName='fldcp' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,fieldcapa) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa) - -! GFS does not have deep convective cloud top and bottom fields - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - HTOPD(i,j) = SPVAL - HBOTD(i,j) = SPVAL - HTOPS(i,j) = SPVAL - HBOTS(i,j) = SPVAL - CUPPT(i,j) = SPVAL - enddo - enddo - -! -!!!! DONE GETTING -! Will derive isobaric OMEGA from continuity equation later. -! OMGA=SPVAL -! -! -! retrieve d3d fields if it's listed -! ---------------------------------- - if (me == 0) print*,'iostatus for d3d file= ',iostatusD3D - if(iostatusD3D == 0) then ! start reading d3d file -! retrieve longwave tendency using getgb - Index=41 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,rlwtt(1,jsta_2l,ll)) - end do - -! retrieve shortwave tendency using getgb - Index=40 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,rswtt(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion tendency using getgb - Index=356 - VarName='VDIFF TNDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdifftt(1,jsta_2l,ll)) - end do - -! retrieve deep convective tendency using getgb - Index=79 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,tcucn(1,jsta_2l,ll)) - end do - -! retrieve shallow convective tendency using getgb - Index=358 - VarName='S CNVCT TNDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,tcucns(1,jsta_2l,ll)) - end do - -! retrieve grid scale latent heat tendency using getgb - Index=78 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,train(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion moistening using getgb - Index=360 - VarName='Vertical diffusion moistening' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdiffmois(1,jsta_2l,ll)) - end do - -! retrieve deep convection moistening using getgb - Index=361 - VarName='deep convection moistening' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,dconvmois(1,jsta_2l,ll)) - end do - -! retrieve shallow convection moistening using getgb - Index=362 - VarName='shallow convection moistening' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sconvmois(1,jsta_2l,ll)) - end do - -! retrieve non-radiation tendency using getgb - Index=363 - VarName='non-radiation tendency' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,nradtt(1,jsta_2l,ll)) - end do - -! retrieve Vertical diffusion of ozone using getgb - Index=364 - VarName='Vertical diffusion of ozone' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,o3vdiff(1,jsta_2l,ll)) - end do - -! retrieve ozone production using getgb - Index=365 - VarName='Ozone production' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,o3prod(1,jsta_2l,ll)) - end do - -! retrieve ozone tendency using getgb - Index=366 - VarName='Ozone tendency' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,o3tndy(1,jsta_2l,ll)) - end do - -! retrieve mass weighted PV using getgb - Index=367 - VarName='Mass weighted PV' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,mwpv(1,jsta_2l,ll)) - end do - -! retrieve OZONE TNDY using getgb - Index=368 - VarName='?' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,unknown(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion zonal acceleration - Index=369 - VarName='VDIFF Z ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdiffzacce(1,jsta_2l,ll)) - end do - -! retrieve gravity drag zonal acceleration - Index=370 - VarName='G DRAG Z ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,zgdrag(1,jsta_2l,ll)) - end do - -! retrieve convective U momemtum mixing - Index=371 - VarName='CNVCT U M MIX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctummixing(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion meridional acceleration - Index=372 - VarName='VDIFF M ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdiffmacce(1,jsta_2l,ll)) - end do - -! retrieve gravity drag meridional acceleration - Index=373 - VarName='G DRAG M ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,mgdrag(1,jsta_2l,ll)) - end do - -! retrieve convective V momemtum mixing - Index=374 - VarName='CNVCT V M MIX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctvmmixing(1,jsta_2l,ll)) - end do - -! retrieve nonconvective cloud fraction - Index=375 - VarName='N CNVCT CLD FRA' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,ncnvctcfrac(1,jsta_2l,ll)) - end do - -! retrieve convective upward mass flux - Index=391 - VarName='CNVCT U M FLX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctumflx(1,jsta_2l,ll)) - end do - -! retrieve convective downward mass flux - Index=392 - VarName='CNVCT D M FLX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctdmflx(1,jsta_2l,ll)) - end do - -! retrieve nonconvective detraintment flux - Index=393 - VarName='CNVCT DET M FLX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctdetmflx(1,jsta_2l,ll)) - end do - -! retrieve cnvct gravity drag zonal acceleration - Index=394 - VarName='CNVCT G DRAG Z ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctzgdrag(1,jsta_2l,ll)) - end do - -! retrieve cnvct gravity drag meridional acceleration - Index=395 - VarName='CNVCT G DRAG M ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctmgdrag(1,jsta_2l,ll)) - end do - - call baclose(iunitd3d,status) - print*,'done reading D3D fields' - - end if ! end of d3d file read - ! -------------------- - print *,'after d3d files reading,mype=',me - -! Retrieve aer fields if it's listed (GOCART) - print *, 'iostatus for aer file=', iostatusAER - if(iostatusAER == 0) then ! start reading aer file - -! retrieve dust emission fluxes - do K = 1, nbin_du - if ( K == 1) VarName='DUEM001' - if ( K == 2) VarName='DUEM002' - if ( K == 3) VarName='DUEM003' - if ( K == 4) VarName='DUEM004' - if ( K == 5) VarName='DUEM005' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,duem(1,jsta_2l,K)) -! if(debugprint)print*,'sample ',VarName,' = ',duem(isa,jsa,k) - enddo - -! retrieve dust sedimentation fluxes - do K = 1, nbin_du - if ( K == 1) VarName='DUSD001' - if ( K == 2) VarName='DUSD002' - if ( K == 3) VarName='DUSD003' - if ( K == 4) VarName='DUSD004' - if ( K == 5) VarName='DUSD005' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dusd(1,jsta_2l,K)) -! if(debugprint)print*,'sample ',VarName,' = ',dusd(isa,jsa,k) - enddo - -! retrieve dust dry deposition fluxes - do K = 1, nbin_du - if ( K == 1) VarName='DUDP001' - if ( K == 2) VarName='DUDP002' - if ( K == 3) VarName='DUDP003' - if ( K == 4) VarName='DUDP004' - if ( K == 5) VarName='DUDP005' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dudp(1,jsta_2l,K)) - print *,'dudp,ck=',maxval(dudp(1:im,jsta:jend,k)), & - minval(dudp(1:im,jsta:jend,k)) -! if(debugprint)print*,'sample ',VarName,' = ',dudp(isa,jsa,k) - enddo - -! retrieve dust wet deposition fluxes - do K = 1, nbin_du - if ( K == 1) VarName='DUWT001' - if ( K == 2) VarName='DUWT002' - if ( K == 3) VarName='DUWT003' - if ( K == 4) VarName='DUWT004' - if ( K == 5) VarName='DUWT005' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,duwt(1,jsta_2l,K)) -! if(debugprint)print*,'sample ',VarName,' = ',duwt(isa,jsa,k) - enddo - -! retrieve sfc mass concentration - VarName='DUSMASS' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dusmass) -! if(debugprint)print*,'sample ',VarName,' = ',dusmass(isa,jsa) - -! retrieve col mass density - VarName='DUCMASS' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ducmass) -! if(debugprint)print*,'sample ',VarName,' = ',ducmass(isa,jsa) - -! retrieve sfc mass concentration (pm2.5) - VarName='DUSMASS25' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dusmass25) -! if(debugprint)print*,'sample ',VarName,' = ',dusmass25(isa,jsa) - -! retrieve col mass density (pm2.5) - VarName='DUCMASS25' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ducmass25) -! if(debugprint)print*,'sample ',VarName,' = ',ducmass25(isa,jsa) - - if (me == 0) print *,'after aer files reading,mype=',me - end if ! end of aer file read - -! pos east - call collect_loc(gdlat,dummy) - if(me == 0)then - latstart = nint(dummy(1,1)*gdsdegr) - latlast = nint(dummy(im,jm)*gdsdegr) - print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,& - 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1) - end if - call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me - call collect_loc(gdlon,dummy) - if(me == 0)then - lonstart = nint(dummy(1,1)*gdsdegr) - lonlast = nint(dummy(im,jm)*gdsdegr) - end if - call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(lonlast, 1,MPI_INTEGER,0,mpi_comm_comp,irtn) - - write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast -! -! ncdump -h -!! -!! - write(6,*) 'filename in INITPOST=', filename,' is' - -! status=nf_open(filename,NF_NOWRITE,ncid) -! write(6,*) 'returned ncid= ', ncid -! status=nf_get_att_real(ncid,varid,'DX',tmp) -! dxval=int(tmp) -! status=nf_get_att_real(ncid,varid,'DY',tmp) -! dyval=int(tmp) -! status=nf_get_att_real(ncid,varid,'CEN_LAT',tmp) -! cenlat=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'CEN_LON',tmp) -! cenlon=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'TRUELAT1',tmp) -! truelat1=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'TRUELAT2',tmp) -! truelat2=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'MAP_PROJ',tmp) -! maptype=int(tmp) -! status=nf_close(ncid) - -! dxval=30000. -! dyval=30000. -! -! write(6,*) 'dxval= ', dxval -! write(6,*) 'dyval= ', dyval -! write(6,*) 'cenlat= ', cenlat -! write(6,*) 'cenlon= ', cenlon -! write(6,*) 'truelat1= ', truelat1 -! write(6,*) 'truelat2= ', truelat2 -! write(6,*) 'maptype is ', maptype -! - -! close up shop -! call ext_int_ioclose ( DataHandle, Status ) - -! generate look up table for lifted parcel calculations - - THL = 210. - PLQ = 70000. - pt_TBL = 10000. ! this is for 100 hPa added by Moorthi - - CALL TABLE(PTBL,TTBL,PT_TBL, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - -! -! - IF(ME == 0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -! COMPUTE DERIVED TIME STEPPING CONSTANTS. -! -!MEB need to get DT -! DT = 120. !MEB need to get DT -! NPHS = 4 !MEB need to get physics DT -! TPREC=float(ifhr) -!MEB need to get DT - -!how am i going to get this information? -! NPREC = INT(TPREC *TSPH+D50) -! NHEAT = INT(THEAT *TSPH+D50) -! NCLOD = INT(TCLOD *TSPH+D50) -! NRDSW = INT(TRDSW *TSPH+D50) -! NRDLW = INT(TRDLW *TSPH+D50) -! NSRFC = INT(TSRFC *TSPH+D50) -!how am i going to get this information? -! -! IF(ME == 0)THEN -! WRITE(6,*)' ' -! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS' -! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC -! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW -! ENDIF -! -! COMPUTE DERIVED MAP OUTPUT CONSTANTS. -!$omp parallel do private(l) - DO L = 1,LSM - ALSL(L) = LOG(SPL(L)) - END DO -! -!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - if(me == 0)then - print*,'writing out igds' - igdout = 110 -! open(igdout,file='griddef.out',form='unformatted' -! + ,status='unknown') - if(maptype == 1)THEN ! Lambert conformal - WRITE(igdout)3 - WRITE(6,*)'igd(1)=',3 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ELSE IF(MAPTYPE == 2)THEN !Polar stereographic - WRITE(igdout)5 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 !Assume projection at +-90 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ! Note: The calculation of the map scale factor at the standard - ! lat/lon and the PSMAPF - ! Get map factor at 60 degrees (N or S) for PS projection, which will - ! be needed to correctly define the DX and DY values in the GRIB GDS - if (TRUELAT1 < 0.) THEN - LAT = -60. - else - LAT = 60. - end if - - CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF) - - ELSE IF(MAPTYPE == 3) THEN !Mercator - WRITE(igdout)1 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)latlast - WRITE(igdout)lonlast - WRITE(igdout)TRUELAT1 - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)255 - ELSE IF(MAPTYPE == 0 .OR. MAPTYPE == 203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - END IF - end if -! -! close all files -! - call nemsio_close(nfile,iret=status) - call nemsio_close(ffile,iret=status) - call nemsio_close(rfile,iret=status) -! call baclose(iunit,status) - - RETURN - END - - diff --git a/sorc/ncep_post.fd/INITPOST_GFS_SIGIO.f b/sorc/ncep_post.fd/INITPOST_GFS_SIGIO.f deleted file mode 100644 index b8ab8755f..000000000 --- a/sorc/ncep_post.fd/INITPOST_GFS_SIGIO.f +++ /dev/null @@ -1,3062 +0,0 @@ -!> @file -! . . . -!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN -!! PRGRMMR: Hui-Ya Chuang DATE: 2007-03-01 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF AN ETA MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 2011-02-07 Jun Wang add grib2 option -!! 2013-04-19 Jun Wang add changes to read wam tracers -!! 2013-05-04 Shrinivas Moorthi: real * 8 for pm1d and pi1d and pt=100hPa and some cosmetic changes -!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INIT -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_GFS_SIGIO(lusig,iunit,iostatusFlux,iostatusD3D,idrt,sighead) - - use vrbls3d, only: ZINT, PINT, T, UH, VH, Q, O3, CWM, U, V, QQW, & - OMGA, PMID, PINT, ALPINT, ZMID, QQR, QQS, QQI, Q2, & - CFR, RLWTT, RSWTT, TCUCN, TCUCNS, TRAIN, EL_PBL, & - EXCH_H, VDIFFTT, VDIFFMOIS, DCONVMOIS, SCONVMOIS, & - NRADTT, O3VDIFF, O3PROD, O3TNDY, MWPV, UNKNOWN, & - VDIFFZACCE, ZGDRAG, CNVCTUMMIXING, VDIFFMACCE, & - MGDRAG, CNVCTDETMFLX,NCNVCTCFRAC, CNVCTUMFLX, & - CNVCTVMMIXING, CNVCTDMFLX, CNVCTZGDRAG, CNVCTMGDRAG - - use vrbls2d, only: F, PD, FIS, PBLH, USTAR, Z0, THS, QS, TWBS, QWBS, & - AVGCPRATE, CPRATE, AVGPREC, PREC, SR, LSPA, SNO, SI, & - CLDEFI, TH10, Q10, TSHLTR, PSHLTR, QSHLTR, ALBASE, & - AVGALBEDO,AVGTCDC, CZEN, CZMEAN, MXSNAL, RADOT, & - SIGT4, VEGFRC, CFRACL, CFRACM, AVGCFRACH, CFRACH, & - AVGCFRACL, AVGCFRACM, CNVCFR, ISLOPE, CMC, GRNFLX, & - SOILTB, TG, NCFRCV, ACFRCV, ASWINTOA, ACFRST, NCFRST,& - SSROFF, BGROFF, RLWIN, RLWTOA, ALWIN, ALWOUT, ALWTOA,& - RSWIN, RSWINC, RSWOUT, ASWIN, AUVBIN, AUVBINC, & - ASWOUT, ASWTOA, ASWINC, ASWOUTC, ASWTOAC, ASWINTOA, & - AVISBEAMSWIN, AVISDIFFSWIN, AIRBEAMSWIN, AIRDIFFSWIN,& - SFCSHX, SFCLHX, SUBSHX, SNOPCX, SFCUX, SFCVX, SFCUVX,& - SFCUGS, GTAUX, SFCVGS, GTAUY, POTEVP, U10, V10, & - SMSTAV, SMSTOT, IVGTYP, ISLTYP, SFCEVP, SFCEXC, & - ACSNOW, ACSNOM, SST, QZ0, UZ0, VZ0, PTOP, HTOP, PBOT,& - HBOT, PBOT, PTOPL, PBOTL, TTOPL, PTOPM, PBOTM, TTOPM,& - PTOPH, PBOTH, TTOPH, PBLCFR, CLDWORK, RUNOFF, & - MAXTSHLTR, MINTSHLTR, DZICE, SMCWLT, SUNTIME, & - FIELDCAPA, SNOWFALL, HTOPD, HBOTD, HTOPS, HBOTS, & - CUPPT, THZ0, MAXRHSHLTR, MINRHSHLTR, U10H, V10H - use soil, only: SLDPTH, SH2O, SMC, STC - use masks, only: LMV, LMH, HTM, VTM, GDLAT, GDLON, DX, DY, HBM2, SM, SICE - use physcons_post, only: CON_G, CON_FVIRT, CON_RD, CON_EPS, CON_EPSM1 - use masks, only: LMV, LMH, HTM, VTM, GDLAT, GDLON, DX, DY, HBM2, & - SM, SICE - use params_mod, only: RTD, ERAD, DTR, TFRZ, P1000, CAPA - use lookup_mod, only: THL, PLQ, PTBL, TTBL, RDQ, RDTH, RDP, RDTHE, PL, & - QS0, SQS, STHE, THE0, TTBLQ, RDPQ, RDTHEQ, STHEQ, & - THE0Q - use ctlblk_mod, only: ME, MPI_COMM_COMP, ICNT, IDSP,JEND_M, IHRST, IMIN,& - IDAT, SDAT, IFHR, IFMIN, FILENAME, TPREC, TCLOD, & - TRDLW, TRDSW, TSRFC, TMAXMIN, TD3D, RESTRT, & - IMP_PHYSICS, DT, NUM_PROCS, LP1, PDTOP, SPVAL, PT,& - NPHS, DTQ2, ARDLW, ARDSW, ASRFC, AVRAIN, AVCNVC, & - THEAT, GDSDEGR, SPL, LSM, ALSL, IM, JM, IM_JM, & - LM, JSTA_2L, JEND_2U, NSOIL, JSTA, JEND, ICU_PHYSICS - use gridspec_mod, only: MAPTYPE, GRIDTYPE, LATSTART, LATLAST, LONSTART, & - LONLAST, CENLON, DXVAL, DYVAL, TRUELAT2, & - TRUELAT1, CENLAT - use rqstfld_mod, only: IGDS, AVBL, IQ, IS - use sigio_module, only: SIGIO_HEAD - use sfcio_module, only: sfcio_head, sfcio_data, sfcio_srohdc - use upp_physics, only: fpvsnew -! use wrf_io_flags_mod -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! - type(sigio_head):: sighead - !type(sigio_data):: sigdatai - type(sfcio_head):: head - type(sfcio_data):: data -! -! INCLUDE/SET PARAMETERS. -! - INCLUDE "mpif.h" - integer,parameter:: MAXPTS=1000000 ! max im*jm points -! -! real,parameter:: con_g =9.80665e+0! gravity -! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O -! real,parameter:: con_rd =2.8705e+2 ! gas constant air -! real,parameter:: con_fvirt =con_rv/con_rd-1. -! real,parameter:: con_eps =con_rd/con_rv -! real,parameter:: con_epsm1 =con_rd/con_rv-1 -! -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - - integer,intent(in) :: lusig,iostatusFlux,iostatusD3D,iunit,idrt - character(len=20) :: VarName - character(len=20) :: VcoordName - integer :: Status - character startdate*19,SysDepInfo*80,cgar*1 - character startdate2(19)*4 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO - LOGICAL IOOMG,IOALL - logical, parameter :: debugprint = .false. -! logical, parameter :: debugprint = .true. - CHARACTER*32 LABEL - CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV & - , FILCLD,FILRAD,FILSFC - CHARACTER*4 RESTHR - CHARACTER FNAME*255,ENVAR*50,sfcfilename*256 - INTEGER IDATE(8),JDATE(8) - INTEGER JPDS(200),JGDS(200),KPDS(200),KGDS(200) - LOGICAL*1 LB(IM,JM) - INTEGER IRET -! REAL BUFF(IM_JM) -! -! INCLUDE COMMON BLOCKS. -! -! DECLARE VARIABLES. -! -! REAL fhour - integer nfhour ! forecast hour from nems io file - REAL RINC(5) - REAL u1d(LM), v1d(LM),omga1d(lm) - real*8 pm1d(lm), pi1d(lm+1) - REAL DUM1D (LM+1) -! REAL DUMMY ( IM, JM ) -! REAL DUMMY2 ( IM, JM ) - REAL, ALLOCATABLE :: dummy_h(:,:),dummy_p(:,:),dummy_px(:,:), & - dummy_py(:,:),dummy_t(:,:,:),dummy_u(:,:,:),dummy_v(:,:,:), & - dummy_d(:,:,:),dummy_trc(:,:,:,:), dummy(:,:), dummy2(:,:) -! dummy18(:,:,:),dummy19(:,:,:) - REAL, ALLOCATABLE :: dummy15(:,:),dummy16(:,:),dummy17(:,:,:) - real, allocatable :: d2d(:,:), u2d(:,:), v2d(:,:), omga2d(:,:), & - p2d(:,:), t2d(:,:), q2d(:,:), qs2d(:,:), & - cw2d(:,:), cfr2d(:,:) - real*8, allocatable :: pm2d(:,:), pi2d(:,:) - real, allocatable :: fi(:,:,:) - -! INTEGER IDUMMY(IM,JM) -!jw - integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, & - I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, & - impf,jmpf,nframed2,iunitd3d - real TSTART,TLMH,TSPH,ES, FACT,soilayert,soilayerb,zhour,dum - - real, allocatable:: glat1d(:),glon1d(:),qstl(:) - integer ierr,idum -! integer ntrac,nci,ij,ijl,j1,j2 - integer lsta,lend - integer ijmc,ijxc,kna,kxa,kma - real,allocatable :: ri(:),cpi(:) -! integer ibuf(im,jsta_2l:jend_2u) -! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) - real buf(im,jsta_2l:jend_2u) - real, allocatable :: buf3d(:,:,:), ta(:,:,:,:), tb(:,:,:,:) - real, allocatable :: wrk1(:,:), wrk2(:,:) -! real buf3d(im,lm,jsta:jend) - real tem,tvll,pmll - integer levs,ntrac,ncld,idvt,jcap,lnt2,ntoz,ntcw,ltrc -! -! DATA BLANK/' '/ -! -!*********************************************************************** -! START INIT HERE. -! - if (me == 0) WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_SIGIO' - WRITE(6,*)'me=',me,'LMV=',size(LMV,1),size(LMV,2),'LMH=', & - size(LMH,1),size(LMH,2),'jsta_2l=',jsta_2l,'jend_2u=', & - jend_2u,'im=',im -! -! -! STEP 1. READ MODEL OUTPUT FILE -! -! -!*** -! -! LMH always = LM for sigma-type vert coord -! LMV always = LM for sigma-type vert coord - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i = 1, im - LMV ( i, j ) = lm - LMH ( i, j ) = lm - end do - end do - -! write(0,*),' LM=',LM,' LP1=',LP1 - -! HTM VTM all 1 for sigma-type vert coord - -!$omp parallel do private(i,j,l) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - HTM ( i, j, l ) = 1.0 - VTM ( i, j, l ) = 1.0 - end do - end do - end do - - allocate (dummy(im,jm), dummy2(im,jm)) - -! The end j row is going to be jend_2u for all variables except for V. - JS = JSTA_2L - JE = JEND_2U -! get start date - if (me == 0)then - idate(1) = sighead%idate(4) - idate(2) = sighead%idate(2) - idate(3) = sighead%idate(3) - idate(4) = sighead%idate(1) - idate(5) = 0 - nfhour = nint(sighead%fhour) - - allocate(glat1d(jm),glon1d(jm)) - -! call splat to compute lat for gaussian grid - call splat(idrt,jm,glat1d,glon1d) - -!$omp parallel do private(i,j,tem) - do j=1,jm - tem = asin(glat1d(j))*RTD - do i=1,im - dummy(i,j) = tem - dummy2(i,j) = 360./im*(i-1) - end do - end do - deallocate(glat1d,glon1d) - - print*,'idate before broadcast = ',(idate(i),i=1,7) - end if - call mpi_bcast(idate(1),7,MPI_INTEGER,0,mpi_comm_comp,iret) - call mpi_bcast(nfhour,1,MPI_INTEGER,0,mpi_comm_comp,iret) - if (me == 0) then - print*,'idate after broadcast = ',(idate(i),i=1,4) - print*,'nfhour = ',nfhour - endif - -! sample print point - ii = im/2 - jj = jm/2 - - call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & - ,gdlat(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,ierr) - call mpi_scatterv(dummy2(1,1),icnt,idsp,mpi_real & - ,gdlon(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,ierr) - - -! write(0,*)'before call EXCH,mype=',me,'max(gdlat)=',maxval(gdlat),& -! 'max(gdlon)=', maxval(gdlon) - - CALL EXCH(gdlat(1,JSTA_2L)) - - print *,'after call EXCH,mype=',me - -!$omp parallel do private(i,j) - do j = jsta, jend_m - do i = 1, im-1 - DX( i,j) = ERAD*COS(GDLAT(I,J)*DTR)*(GDLON(I+1,J)-GDLON(I,J))*DTR - DY(i,j) = ERAD*(GDLAT(I,J)-GDLAT(I,J+1))*DTR ! like A*DPH -! F(I,J)=1.454441e-4*sin(gdlat(i,j)*DTR) ! 2*omeg*sin(phi) - end do - end do - if (me == 0) print*,'sample LATLON, DY, DY=',ii,jend, & - GDLAT(II,JEND),GDLON(II,JEND),DX(II,JEND),DY(II,JEND) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - F(I,J) = 1.454441e-4*sin(gdlat(i,j)*DTR) ! 2*omeg*sin(phi) - end do - end do - - impf = im - jmpf = jm - if (me == 0) print*,'impf,jmpf= ',impf,jmpf -!Moo print*,'impf,jmpf,nframe= ',impf,jmpf,nframe - -! iyear=idate(4)+2000 ! older gfsio only has 2 digit year - iyear = idate(1) - imn = idate(2) ! ask Jun - iday = idate(3) ! ask Jun - ihrst = idate(4) - imin = idate(5) - jdate = 0 - idate = 0 -! -! read(startdate,15)iyear,imn,iday,ihrst,imin - 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2) - if (me == 0) then - print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin - print*,'processing yr mo day hr min=' & - ,idat(3),idat(1),idat(2),idat(4),idat(5) - endif -! - idate(1) = iyear - idate(2) = imn - idate(3) = iday - idate(5) = ihrst - idate(6) = imin - SDAT(1) = imn - SDAT(2) = iday - SDAT(3) = iyear - jdate(1) = idat(3) - jdate(2) = idat(1) - jdate(3) = idat(2) - jdate(5) = idat(4) - jdate(6) = idat(5) -! -! CALL W3DIFDAT(JDATE,IDATE,2,RINC) -! ifhr=nint(rinc(2)) -! - CALL W3DIFDAT(JDATE,IDATE,0,RINC) -! - ifhr = nint(rinc(2)+rinc(1)*24.) - ifmin = nint(rinc(3)) -! if(ifhr /= nint(fhour))print*,'find wrong Grib file';stop - if (me == 0) then - print *,' idate=',idate - print *,' rinc=',rinc - print *,' ifhr=',ifhr - print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,fileName - -! GFS has the same accumulation bucket for precipitation and fluxes and it is written to header -! the header has the start hour information so post uses it to recontruct bucket - tprec = 6. - if(ifhr>240)tprec=12. - tclod = tprec - trdlw = tprec - trdsw = tprec - tsrfc = tprec - tmaxmin = tprec - td3d = tprec - print*,'tprec = ',tprec - end if - - call mpi_bcast(tprec,1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(tclod,1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(trdlw,1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(trdsw,1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(tsrfc,1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(tmaxmin,1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(td3d,1,MPI_REAL,0,mpi_comm_comp,iret) - -! Getting tstart - tstart = 0. - - print*,'tstart= ',tstart - -! Getiing restart - - RESTRT=.TRUE. ! set RESTRT as default - - IF(tstart > 1.0E-2)THEN - ifhr = ifhr+NINT(tstart) - rinc = 0 - idate = 0 - rinc(2) = -1.0*ifhr - call w3movdat(rinc,jdate,idate) - SDAT(1) = idate(2) - SDAT(2) = idate(3) - SDAT(3) = idate(1) - IHRST = idate(5) - print*,'new forecast hours for restrt run= ',ifhr - print*,'new start yr mo day hr min =',sdat(3),sdat(1) & - ,sdat(2),ihrst,imin - END IF - - imp_physics = 99 !set GFS mp physics to 99 for Zhao scheme - iCU_PHYSICS = 4 - print*,'MP_PHYSICS=,cu_physics=',imp_physics,icu_physics - -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then - CALL MICROINIT(imp_physics) - end if - -! waiting to retrieve lat lon infor from raw GFS output -! VarName='DX' - -! VarName='DY' - -! GFS does not need DT to compute accumulated fields, set it to one -! VarName='DT' - DT = 1 -! GFS does not need truelat -! VarName='TRUELAT1' - -! VarName='TRUELAT2' - -! Specify maptype=4 for Gaussian grid -! maptype=4 -! write(6,*) 'maptype is ', maptype -! HBM2 is most likely not in Grib message, set them to ones - HBM2 = 1.0 - -! try to get kgds from flux grib file and then convert to igds that is used by GRIBIT.f - - if(me == 0)then - jpds = -1.0 - jgds = -1.0 - igds = 0 - call getgb(iunit,0,im_jm,0,jpds,jgds,kf & - ,k,kpds,kgds,lb,dummy,ierr) - if(ierr == 0)then - call R63W72(KPDS,KGDS,JPDS,IGDS(1:18)) - print*,'use IGDS from flux file for GFS= ',(IGDS(I),I=1,18) - else - print*,'no flux file, fill part of kgds with sigma file info' - kgds(1) = idrt - kgds(2) = im - kgds(3) = jm - end if - end if - call mpi_bcast(igds(1),18,MPI_INTEGER,0,mpi_comm_comp,iret) - call mpi_bcast(kgds(1),18,MPI_INTEGER,0,mpi_comm_comp,iret) - print*,'IGDS for GFS= ',(IGDS(I),I=1,18) - -! Specigy grid type -! if(iostatusFlux==0)then - if(IGDS(4) /= 0)then - maptype = IGDS(3) - else if((im/2+1) == jm)then - maptype = 0 !latlon grid - else - maptype = 4 ! default gaussian grid - end if - gridtype = 'A' - - write(6,*) 'maptype and gridtype is ', maptype,gridtype - if(idrt /= maptype)then - print*,'flux file and sigma file are on different grids - ', & - 'post processing isterminated' - call mpi_abort() - stop - end if - - levs = sighead%levs - ntrac = sighead%ntrac - ncld = sighead%ncldt - idvt = sighead%idvt - jcap = sighead%jcap - lnt2 = (jcap+1)*(jcap+2) - ntoz = mod(idvt,10) + 1 -!jw ntcw = idvt/10 + 1 - if( idvt/100 > 0 ) then - ntcw = 3 - else - ntcw = idvt/10 + 1 - endif - -! start reading sigma file -! decompose l to read different levs with different pes - call mptgen(me,num_procs,1,1,lm,lsta,lend,kxa,kma,kna) - - write(0,*)' me=',me,' lsta=',lsta,' lend=',lend,' kxa=',kxa, & - ' kma=',kma,' kna=',kna - ii = im/2 - jj = (jsta+jend)/2 - - print*,'lsta, lend= ',lsta,lend - if (lsta > lend) lend = lsta - - allocate(dummy_h(im,jm),dummy_p(im,jm),dummy_px(im,jm),dummy_py(im,jm) & - ,dummy_t(im,jm,lsta:lend),dummy_u(im,jm,lsta:lend) & - ,dummy_v(im,jm,lsta:lend),dummy_d(im,jm,lsta:lend) & - ,dummy_trc(im,jm,lsta:lend,ntrac)) - -! ,dummy12(im,jm,lsta:lend), & -! dummy13(im,jm,lsta:lend),dummy14(im,jm,lsta:lend), & -! dummy18(im,jm,lsta:lend),dummy19(im,jm,lsta:lend) ) - - if (me == 0) then - print*,'calling rtsig with lusig,lsta,lend,im_jm,kgds= ', & - lusig,lsta,lend,im_jm,kgds(1:20) - - write(0,*)' levs=',levs,' ntrac=',ntrac,' ncld=',ncld,' jcap=',jcap & - ,' lnt2=',lnt2,' ntoz=',ntoz,' ntcw=',ntcw - endif - - call rtsig(lusig,sighead,lsta,lend,kgds,im_jm, & ! input - levs,ntrac,jcap,lnt2,me, & ! input - dummy_h,dummy_p,dummy_px,dummy_py, & ! output - dummy_t,dummy_u,dummy_v,dummy_d, & ! output - dummy_trc,iret) ! output - write(0,*)'aft rtsig,iret=',iret - - if(iret /= 0)then - print*,'error reading sigma file, stopping' - print*,'error massage is ',iret - call mpi_abort() - end if - - if(Debugprint)print*,'done with rtsig, sample t,u,v,q,cwm= ', & - dummy_t(1,1,lsta:lend), dummy_u(1,1,lsta:lend), & - dummy_v(1,1,lsta:lend), dummy_trc(1,1,lsta:lend,1), & - dummy_trc(1,1,lsta:lend,3),' lsta=',lsta,'lend=',lend -! write(0,*)'bf allocate ' - -! set threads for rest of the code -! call getenv('POST_THREADS',ENVAR) -! read(ENVAR, '(I2)')idum -! idum = max(idum+0,1) -! write(0,*)' post_threads=', idum -! if (idum > 0 .and. idum <= 32) then -! call OMP_SET_NUM_THREADS(idum) -! endif - -! scatter to pes - allocate(dummy15(im,jsta_2l:jend_2u), & - dummy16(im,jsta_2l:jend_2u),dummy17(im,jsta_2l:jend_2u,lm)) - -! write(0,*)'af allocate ' - -! call mpi_scatterv(dummy_h(1,1),icnt,idsp,mpi_real & -! ,zint(1,jsta,lp1),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! call mpi_scatterv(dummy_p(1,1),icnt,idsp,mpi_real & -! ,pint(1,jsta,lp1),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! call mpi_scatterv(dummy_px(1,1),icnt,idsp,mpi_real & -! ,dummy15(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! call mpi_scatterv(dummy_py(1,1),icnt,idsp,mpi_real & -! ,dummy16(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) - -!$omp parallel do private(i,j) - do j=jsta, jend - do i=1, im - zint(i,j,lp1) = dummy_h(i,j) - pint(i,j,lp1) = dummy_p(i,j) - dummy15(i,j) = dummy_px(i,j) - dummy16(i,j) = dummy_py(i,j) - enddo - enddo - deallocate (dummy_h,dummy_p,dummy_px,dummy_py) - - write(0,*)'one scattering zs and ps',zint(ii,jj,lp1),pint(ii,jj,lp1) - - - ijmc = (jm-1)/num_procs+1 - ijxc = jend-jsta+1 - - allocate (ta(im,ijmc,kma,num_procs)) - allocate (tb(im,ijmc,kma,num_procs)) - allocate (buf3d(im,lm,jsta:jend)) - -! write(0,*)'be mptranr4' - if(ijxc > ijmc) print*,'ijxc larger than ijmc =',ijxc,ijmc - call mptranr4(MPI_COMM_COMP,num_procs,im,im,im, & - ijmc,jm,ijxc,jm,kma,kxa,lm,lm,dummy_t,buf3d,ta,tb) -! write(0,*)'be set buf3d' -!$omp parallel do private(i,j,l,ll) - do l=1, lm - ll = lm-l+1 - do j=jsta, jend - do i=1, im - T(i,j,l) = buf3d(i,ll,j) - end do - end do - end do - if (debugprint) then - do l=1, lm - print*,'sample i,j,l, T = ',ii,jj,l,t(ii,jj,l) - enddo - endif - -! write(0,*)'be set uh' - call mptranr4(MPI_COMM_COMP,num_procs,im,im,im, & - ijmc,jm,ijxc,jm,kma,kxa,lm,lm,dummy_u,buf3d,ta,tb) -!$omp parallel do private(i,j,l,ll) - do l=1, lm - ll = lm-l+1 - do j=jsta, jend - do i=1, im - uh(i,j,l) = buf3d(i,ll,j) - end do - end do - end do - if (debugprint) then - do l=1, lm - print*,'sample i,j,l,U = ',ii,jj,l,uh(ii,jj,l) - enddo - endif - -! write(0,*)'be set vh' - call mptranr4(MPI_COMM_COMP,num_procs,im,im,im, & - ijmc,jm,ijxc,jm,kma,kxa,lm,lm,dummy_v,buf3d,ta,tb) -!$omp parallel do private(i,j,l,ll) - do l=1, lm - ll = lm-l+1 - do j=jsta, jend - do i=1, im - vh(i,j,l) = buf3d(i,ll,j) - end do - end do - end do - if (debugprint) then - do l=1, lm - print*,'sample i,j,l,V = ',ii,jj,l,vh(ii,jj,l) - enddo - endif -! - -! ltrc = min(lsta,levs) ! For processors greater than levs - -! write(0,*)'be set q' - call mptranr4(MPI_COMM_COMP,num_procs,im,im,im,ijmc,jm, & - ijxc,jm,kma,kxa,lm,lm,dummy_trc(1,1,lsta,1),buf3d,ta,tb) -!$omp parallel do private(i,j,l,ll) - do l=1, lm - ll = lm-l+1 - do j=jsta, jend - do i=1, im - q(i,j,l) = buf3d(i,ll,j) - end do - end do - end do - if (debugprint) then - do l=1, lm - print*,'sample i,j,l,Q = ',ii,jj,l,q(ii,jj,l) - enddo - endif - -! write(0,*)'be set o3' - call mptranr4(MPI_COMM_COMP,num_procs,im,im,im,ijmc,jm, & - ijxc,jm,kma,kxa,lm,lm,dummy_trc(1,1,lsta,ntoz),buf3d,ta,tb) -!$omp parallel do private(i,j,l,ll) - do l=1, lm - ll = lm-l+1 - do j=jsta, jend - do i=1, im - o3(i,j,l) = buf3d (i,ll,j) - end do - end do - end do - if (debugprint) then - do l=1, lm - print*,'sample i,j,l,O3 = ',ii,jj,l,o3(ii,jj,l) - enddo - endif - -! write(0,*)'be set cld,ntcw=',ntcw - call mptranr4(MPI_COMM_COMP,num_procs,im,im,im,ijmc,jm, & - ijxc,jm,kma,kxa,lm,lm,dummy_trc(1,1,lsta,ntcw),buf3d,ta,tb) -! write(0,*)'aft mptranr4 cwm' -!$omp parallel do private(i,j,l,ll) - do l=1, lm - ll = lm-l+1 - do j=jsta, jend - do i=1, im - cwm(i,j,l ) = buf3d (i,ll,j) - end do - end do - end do - if (debugprint) then - do l=1, lm - print*,'sample i,j,l,CWM = ',ii,jj,l,cwm(ii,jj,l) - enddo - endif -! write(0,*)' cwm=',cwm(1,36,100:150)*1000 - -! write(0,*)'be set div' - call mptranr4(MPI_COMM_COMP,num_procs,im,im,im, & - ijmc,jm,ijxc,jm,kma,kxa,lm,lm,dummy_d,buf3d,ta,tb) -!$omp parallel do private(i,j,l) - do l=1, lm - do j=jsta, jend - do i=1, im - dummy17(i,j,l ) = buf3d(i,l,j) - end do - end do - end do - if (debugprint) then - do l=1, lm - print*,'sample i,j,l,DIV = ',ii,jj,l,dummy17(ii,jj,l) - enddo - endif - - deallocate(dummy_t,dummy_u,dummy_v,dummy_d,dummy_trc,ta,tb,buf3d) -! dummy18,dummy19) - -!$omp parallel do private(i,j,l) - do l=1,lm -! if(debugprint)print*,'sample T Q U V,CWM',l,VarName,' = ',l,t(ii,jj,l),& -! q(ii,jj,l),u(ii,jj,l),v(ii,jj,l),cwm(ii,jj,l) - do j=jsta,jend - do i=1,im - if(t(i,j,l) < (TFRZ-15.) ) then ! separating cloud water from ice - qqi(i,j,l) = cwm(i,j,l) - else - qqw(i,j,l) = cwm(i,j,l) - end if - end do - end do - end do ! for l loop - -! write(0,*)'be set qqi' -! write(0,*)' qqw=',qqw(1,36,100:150) -! write(0,*)' qqi=',qqi(1,36,100:150) - -! compute model level pressure and omega - - pdtop = spval -! pt = 0. - pt = 10000. ! this is for 100 hPa added by Moorthi - pd = spval ! GFS does not output PD - - allocate (d2d(im,lm),u2d(im,lm),v2d(im,lm),pi2d(im,lm+1), & - pm2d(im,lm),omga2d(im,lm)) - - do j=jsta,jend -!$omp parallel do private(i,l,ll) - do l=1,lm - ll = lm-l+1 - do i=1,im - u2d(i,l) = uh(i,j,ll) ! flipping u and v for calling modstuff - v2d(i,l) = vh(i,j,ll) - d2d(i,l) = dummy17(i,j,l) - end do - end do - call modstuff2(im,im,lm, & - sighead%idvc,sighead%idsl,sighead%nvcoord, & - sighead%vcoord,pint(1,j,lp1),dummy15(1,j), & - dummy16(1,j),d2d,u2d,v2d, & - pi2d,pm2d,omga2d,me) -!$omp parallel do private(i,l,ll) - do l=1,lm - ll = lm-l+1 - do i=1,im - omga(i,j,l) = omga2d(i,ll) - pmid(i,j,l) = pm2d(i,ll) - pint(i,j,l) = pi2d(i,ll+1) - enddo - enddo - enddo ! end of j loop -! write(0,*)'be set pint' - -! write(0,*)' PINT=',pint(ii,jj,:),' me=',me - - deallocate(dummy15,dummy16,dummy17) - deallocate (d2d,u2d,v2d,pi2d,pm2d,omga2d) - - allocate(wrk1(im,jsta:jend),wrk2(im,jsta:jend)) - allocate(fi(im,jsta:jend,2)) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - alpint(i,j,lp1) = log(pint(i,j,lp1)) - wrk1(i,j) = log(PMID(I,J,LM)) - wrk2(i,j) = T(I,J,LM)*(Q(I,J,LM)*con_fvirt+1.0) - fis(i,j) = zint(i,j,lp1)*con_G - FI(I,J,1) = FIS(I,J) & - + wrk2(i,j)*con_rd*(ALPINT(I,J,Lp1)-wrk1(i,j)) - ZMID(I,J,LM) = FI(I,J,1)/con_G - enddo - enddo -! write(0,*)'be set zmid' - -! SECOND, INTEGRATE HEIGHT HYDROSTATICLY, GFS integrate height on mid-layer - ii = im/2 - jj = (jsta+jend)/2 - - DO L=LM,2,-1 ! omit computing model top height because it's infinity - ll = l - 1 -!$omp parallel do private(i,j,tvll,pmll,fact) - do j = jsta, jend -! write(0,*)' j=',j,' l=',l,' T=',T(1,j,l),' Q=',q(1,j,l), & -! ' pmid=',pmid(1,j,ll),pmid(1,j,l),' l=',l - do i = 1, im - -! if (me == 40) & -! write(0,*)' i=',i,' j=',j,' l=',l,' T=',T(i,j,l),' Q=',q(i,j,l),& -! ' pmid=',pmid(i,j,ll),pmid(i,j,l),' l=',l - - alpint(i,j,l) = log(pint(i,j,l)) - tvll = T(I,J,LL)*(Q(I,J,LL)*con_fvirt+1.0) - pmll = log(PMID(I,J,LL)) - - FI(I,J,2) = FI(I,J,1) + (0.5*con_rd)*(wrk2(i,j)+tvll) & - * (wrk1(i,j)-pmll) - ZMID(I,J,LL) = FI(I,J,2)/con_G -! - FACT = (ALPINT(I,J,L)-wrk1(i,j)) / (pmll-wrk1(i,j)) - ZINT(I,J,L) = ZMID(I,J,L) + (ZMID(I,J,LL)-ZMID(I,J,L)) * FACT - -! if(i==ii.and.j==jj) & -! print*,'L,sample T,Q,ALPMID(L+1),ALPMID(L),ZMID= ' & -! ,l,T(I,J,L),Q(I,J,L),LOG(PMID(I,J,L+1)), & -! LOG(PMID(I,J,L)),ZMID(I,J,L) - - FI(I,J,1) = FI(I,J,2) - wrk1(i,J) = pmll - wrk2(i,j) = tvll - ENDDO - ENDDO - - if (me == 0) print*,'L ZINT= ',l,zint(ii,jj,l), & - 'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)),'pmid(l-1)=', & - LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L),'zmid(l-1)=',ZMID(Ii,Jj,L-1) - ENDDO - deallocate(wrk1,wrk2,fi) - -! write(0,*)'af sigma file' -! start retrieving data using getgb, first land/sea mask - - Index = 50 - VarName = avbl(index) - jpds = -1 - jgds = -1 - jpds(5) = iq(index) - jpds(6) = is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sm) - where(sm /= spval) sm = 1.0 - sm ! convert to sea mask -! write(0,*)'get land-see mask' - - if(debugprint)print*,'sample ',VarName,' = ',sm(im/2,(jsta+jend)/2) - -! sea ice mask using getgb - Index = 51 - VarName = avbl(index) - jpds = -1.0 - jgds = -1.0 - jpds(5) = iq(index) - jpds(6) = is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sice) - where(sm/=spval .and. sm==0.0) sice = 0.0 !specify sea ice=0 at land - - if(debugprint)print*,'sample ',VarName,' = ',sice(im/2,(jsta+jend)/2) - -! Zhao scheme does not produce suspended rain and snow - qqr = 0. - qqs = 0. - -! PBL height using getgb - Index = 221 - VarName = avbl(index) - jpds = -1.0 - jgds = -1.0 - jpds(5) = iq(index) - jpds(6) = is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,pblh) - - if(debugprint)print*,'sample ',VarName,' = ',pblh(im/2,(jsta+jend)/2) - -! frictional velocity using getgb - Index=45 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,ustar) - if(debugprint)print*,'sample ',VarName,' = ',ustar(im/2,(jsta+jend)/2) - -! roughness length using getgb - Index=44 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,z0) - if(debugprint)print*,'sample ',VarName,' = ',z0(im/2,(jsta+jend)/2) - -! surface potential T using getgb - Index=26 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,ths) - - -! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (ths(i,j) /= spval) then -! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) - ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa - endif - enddo - enddo - - if(debugprint)print*,'sample ',VarName,' = ',ths(im/2,(jsta+jend)/2) - - QS = SPVAL ! GFS does not have surface specific humidity - twbs = SPVAL ! GFS does not have inst sensible heat flux - qwbs = SPVAL ! GFS does not have inst latent heat flux - -! GFS does not have time step and physics time step, make up ones since they -! are not really used anyway - NPHS = 2. - DT = 80. - DTQ2 = DT * NPHS !MEB need to get physics DT - TSPH = 3600./DT !MEB need to get DT - -! convective precip in m per physics time step using getgb - Index=272 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) -! jpds(16)=3 ! CFSRR uses 1 for fhr>1532 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,avgcprate) - where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m - if(debugprint)print*,'sample ',VarName,' = ',avgcprate(im/2,(jsta+jend)/2) - - cprate=avgcprate - -! construct tprec from flux grib massage -! comment this out because you can't get precip bucket from flux file -! if(me==0 .and. iostatusFlux==0)then -! if(kpds(16)==3)then ! Grib1 can't specify accumulated field fhr>1532 -! if(KPDS(13)==1)then -! TPREC=float(KPDS(15)-KPDS(14)) -! else if(KPDS(13)==10)then -! TPREC=float(KPDS(15)-KPDS(14))*3.0 -! else if(KPDS(13)==11)then -! TPREC=float(KPDS(15)-KPDS(14))*6.0 -! else if(KPDS(13)==12)then -! TPREC=float(KPDS(15)-KPDS(14))*12.0 -! else if(KPDS(13)==2)then -! TPREC=float(KPDS(15)-KPDS(14))*24.0 -! else -! TPREC=float(KPDS(15)-KPDS(14)) -! end if -! else -! CALL GETENV('FHZER',ENVAR) -! read(ENVAR, '(I2)')idum -! tprec = idum * 1.0 -! print*,'TPREC from FHZER= ',tprec -! end if -! end if -! call mpi_bcast(tprec,1,MPI_REAL,0,mpi_comm_comp,iret) - -! precip rate in m per physics time step using getgb - Index=271 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,avgprec) - where(avgprec /= spval) avgprec = avgprec*dtq2/1000. ! convert to m - - if(debugprint)print*,'sample ',VarName,' = ',avgprec(im/2,(jsta+jend)/2) - -! inst precip rate in m per physics time step using sfcio - if(me==0)then - call getenv('SFCINPUT',sfcfilename) - print*,'opening sfcfile to read',sfcfilename - call sfcio_srohdc(35,sfcfilename,head,data,iret) - if(iret /=0 )then - print*,'fail to read ',sfcfilename - dummy = spval - dummy2 = spval - else - dummy = data%tprcp - print '(f8.2)',dummy(1,1) -! dummy2 = data%srflag - end if - end if - - call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & - ,prec(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) - - print*,'sampe inst precip= ',prec(im/2,jsta) - - where(prec /= spval) prec = prec*dtq2/1000. ! convert to m - -! call mpi_scatterv(dummy2(1,1),icnt,idsp,mpi_real & -! ,sr(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! print*,'sampe GFS sr= ',sr(im/2,jsta) - - deallocate(dummy2) -! prec=avgprec !set avg cprate to inst one to derive other fields - -! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f - - - lspa = spval ! GFS does not have similated precip - -! inst snow water eqivalent using getgb - Index=119 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sno) - - if(debugprint)print*,'sample ',VarName,' = ',sno(im/2,(jsta+jend)/2) - -! snow depth in mm using getgb - Index=224 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,si) - where(si /= spval) si = si*1000. ! convert to mm - - if(debugprint)print*,'sample ',VarName,' = ',si(im/2,(jsta+jend)/2) - - CLDEFI = SPVAL ! GFS does not have convective cloud efficiency - TH10 = SPVAL ! GFS does not have 10 m theta - Q10 = SPVAL ! GFS does not have 10 m humidity - -! 2m T using nemsio - Index=106 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=2 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,tshltr) - if(debugprint)print*,'sample ',VarName,' = ',tshltr(im/2,(jsta+jend)/2) - -! GFS does not have 2m pres, estimate it, also convert t to theta -!$omp parallel do private(i,j) - Do j=jsta,jend - Do i=1,im - if(tshltr(i,j) /= spval)then - -! if (me == 127) write(0,*)' i=',i,' j=',j,' tshltr=',tshltr(i,j) & -! ,' pint=',pint(I,J,lm+1) - - PSHLTR(I,J) = pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j) = tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta - else - PSHLTR(I,J) = spval - end if -! if (j==jm/2 .and. mod(i,50)==0) -! + print*,'sample 2m T and P after scatter= ' -! + ,i,j,tshltr(i,j),pshltr(i,j) - end do - end do - -! 2m specific humidity using gfsio -! VarName='spfh' -! VcoordName='2m above gnc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + ,qshltr(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! 2m specific humidity using nemsio - Index=112 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,qshltr) - if(debugprint)print*,'sample ',VarName,' = ',qshltr(im/2,(jsta+jend)/2) - - Q2 = SPVAL ! GFS does not have TKE because it uses GFS scheme - ! GFS does not have surface exchange coeff - ALBASE = SPVAL ! GFS does not have snow free albedo - -! mid day avg albedo in fraction using nemsio - Index=266 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,avgalbedo) - where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction - if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(im/2,(jsta+jend)/2) - -! time averaged column cloud fractionusing nemsio - Index=144 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,avgtcdc) - where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction - if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(im/2,(jsta+jend)/2) - -! if(me==0 .and. iostatusFlux==0)then -! if(KPDS(13)==1)then -! TCLOD=float(KPDS(15)-KPDS(14)) -! else if(KPDS(13)==10)then -! TCLOD=float(KPDS(15)-KPDS(14))*3.0 -! else if(KPDS(13)==11)then -! TCLOD=float(KPDS(15)-KPDS(14))*6.0 -! else if(KPDS(13)==12)then -! TCLOD=float(KPDS(15)-KPDS(14))*12.0 -! else if(KPDS(13)==2)then -! TCLOD=float(KPDS(15)-KPDS(14))*24.0 -! else -! TCLOD=float(KPDS(15)-KPDS(14)) -! end if -! end if -! call mpi_bcast(tclod,1,MPI_REAL,0,mpi_comm_comp,iret) -! print*,'TCLOD from flux grib massage= ',TCLOD - - Czen = spval ! GFS probably does not use zenith angle (What???) - CZMEAN = SPVAL - -! maximum snow albedo in fraction using nemsio - Index=227 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,mxsnal) - where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction - if(debugprint)print*,'sample ',VarName,' = ',mxsnal(im/2,(jsta+jend)/2) - - radot = spval ! GFS does not have inst surface outgoing longwave - -! GFS probably does not use sigt4, set it to sig*t^4 -!$omp parallel do private(i,j,tlmh) - Do j=jsta,jend - Do i=1,im - TLMH = T(I,J,LM) - Sigt4(I,j) = 5.67E-8*TLMH*TLMH*TLMH*TLMH - End do - End do - -! TG is not used, skip it for now -! allocate(qstl(lm)) - allocate(p2d(im,lm),t2d(im,lm),q2d(im,lm),cw2d(im,lm), & - qs2d(im,lm),cfr2d(im,lm)) - do j=jsta,jend -!$omp parallel do private(i,k,es) - do k=1,lm - do i=1,im - p2d(i,k) = pmid(i,j,k)*0.01 - t2d(i,k) = t(i,j,k) - q2d(i,k) = q(i,j,k) - cw2d(i,k) = cwm(i,j,k) - es = min(fpvsnew(t(i,j,k)),pmid(i,j,k)) - qs2d(i,k) = con_eps*es/(pmid(i,j,k)+con_epsm1*es)!saturation q for GFS - enddo - enddo - call progcld1 & -!................................... -! --- inputs: - ( p2d,t2d,q2d,qs2d,cw2d,im,lm,0, & -! --- outputs: - cfr2d & - ) -!$omp parallel do private(i,k) - do k=1,lm - do i=1,im - cfr(i,j,k) = cfr2d(i,k) - enddo - end do - end do - deallocate(p2d,t2d,q2d,qs2d,cw2d,cfr2d) - -! ask moorthi if there is snow rate in GFS -! varname='SR' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! SR=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im -! this_length=im*(jend_2u-jsta_2l+1) -! call mpi_file_read_at(iunit,this_offset -! + ,sr,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! SR=SPVAL -! end if -! end if - -! GFS does not have inst cloud fraction for high, middle, and low cloud - cfrach = spval - cfracl = spval - cfracm = spval - -! ave high cloud fraction using nemsio - Index=302 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,avgcfrach) - where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction - - if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(im/2,(jsta+jend)/2) - -! ave low cloud fraction using nemsio - VarName='tcdc' - Index=300 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,avgcfracl) - where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction - if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(im/2,(jsta+jend)/2) - -! ave middle cloud fraction using nemsio - VarName='tcdc' - VcoordName='mid cld lay' - Index=301 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,avgcfracm) - where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction - if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(im/2,(jsta+jend)/2) - -! inst convective cloud fraction using nemsio - VarName='tcdc' - VcoordName='convect-cld laye' - Index=196 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=71 - jpds(6)=244 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvcfr) - where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction - if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(im/2,(jsta+jend)/2) - -! slope type using nemsio - Index=223 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,buf) - where(buf /= spval)islope=nint(buf) - if(debugprint)print*,'sample ',VarName,' = ',islope(im/2,(jsta+jend)/2) - -! plant canopy sfc wtr in m using nemsio - VarName='cnwat' - VcoordName='sfc' - Index=118 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cmc) - where(cmc /= spval)cmc=cmc/1000. ! convert from kg*m^2 to m - if(debugprint)print*,'sample ',VarName,' = ',cmc(im/2,(jsta+jend)/2) - - grnflx = spval ! GFS does not have inst ground heat flux - -! GFS does not have snow cover yet -! VarName='gflux' -! VcoordName='sfc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + , pctsno(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - - soiltb = spval - tg = spval -! vegetation fraction in fraction. using nemsio - VarName='veg' - VcoordName='sfc' - Index=170 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vegfrc) - where(vegfrc /= spval) - vegfrc = vegfrc/100. ! convert to fraction - elsewhere (vegfrc == spval) - vegfrc = 0. ! set to zero to be reasonable input for crtm - end where - if(debugprint)print*,'sample ',VarName,' = ',vegfrc(im/2,(jsta+jend)/2) - -! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam - - SLDPTH(1) = 0.10 - SLDPTH(2) = 0.3 - SLDPTH(3) = 0.6 - SLDPTH(4) = 1.0 - -! liquid volumetric soil mpisture in fraction using nemsio - VarName='soill' - VcoordName='0-10 cm down' - Index=225 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - do l=1,nsoil - if(l == 1)then - jpds(7)=nint(sldpth(1)*100.) - else - soilayert=0 - do n=1,l-1 - soilayert=soilayert+sldpth(n)*100. - end do - soilayerb=soilayert+sldpth(l)*100. - jpds(7)=nint(soilayert*256.+soilayerb) - end if - - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sh2o(1,jsta_2l,l)) - if(debugprint)print*,'sample l',VarName,' = ',l,sh2o(im/2,(jsta+jend)/2,1) - End do ! do loop for l - -! volumetric soil moisture using nemsio - VarName='soilw' - VcoordName='0-10 cm down' - Index=117 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - do l=1,nsoil - if(l == 1)then - jpds(7)=nint(sldpth(1)*100.) - else - soilayert=0 - do n=1,l-1 - soilayert=soilayert+sldpth(n)*100. - end do - soilayerb=soilayert+sldpth(l)*100. - jpds(7)=nint(soilayert*256.+soilayerb) - end if - - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,smc(1,jsta_2l,l)) - if(debugprint)print*,'sample l',VarName,' = ',l,smc(im/2,(jsta+jend)/2,1) - End do ! do loop for l - -! soil temperature using nemsio - VarName='tmp' - VcoordName='0-10 cm down' - Index=116 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=11 ! GFS used 11 for soil T instead of 85 - jpds(6)=is(index) - do l=1,nsoil - if(l == 1)then - jpds(7)=nint(sldpth(1)*100.) - else - soilayert=0 - do n=1,l-1 - soilayert=soilayert+sldpth(n)*100. - end do - soilayerb=soilayert+sldpth(l)*100. - jpds(7)=nint(soilayert*256.+soilayerb) - end if - - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,stc(1,jsta_2l,l)) - - if(debugprint)print*,'sample l','stc',' = ',1,stc(im/2,(jsta+jend)/2,1) - End do ! do loop for l - -! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 - acfrcv = spval - ncfrcv = 1.0 -! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 - acfrst = spval - ncfrst = 1.0 - -! GFS does not have storm runoff - ssroff = spval - -! GFS does not have UNDERGROUND RUNOFF - bgroff = spval - -! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1 - ardlw = 1.0 -! trdlw=6.0 - -! GFS does not have inst incoming sfc longwave - rlwin = spval - -! GFS does not have inst model top outgoing longwave - rlwtoa = spval - -! time averaged incoming sfc longwave using nemsio - VarName='dlwrf' - VcoordName='sfc' - Index=127 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,alwin) - -! if(me==0 .and. iostatusFlux==0)then -! if(KPDS(13)==1)then -! TRDLW=float(KPDS(15)-KPDS(14)) -! else if(KPDS(13)==10)then -! TRDLW=float(KPDS(15)-KPDS(14))*3.0 -! else if(KPDS(13)==11)then -! TRDLW=float(KPDS(15)-KPDS(14))*6.0 -! else if(KPDS(13)==12)then -! TRDLW=float(KPDS(15)-KPDS(14))*12.0 -! else if(KPDS(13)==2)then -! TRDLW=float(KPDS(15)-KPDS(14))*24.0 -! else -! TRDLW=float(KPDS(15)-KPDS(14)) -! end if -! end if -! call mpi_bcast(TRDLW,1,MPI_REAL,0,mpi_comm_comp,iret) -! print*,'TRDLW from flux grib massage= ',TRDLW - -! time averaged outgoing sfc longwave using gfsio - VarName='ulwrf' - VcoordName='sfc' - Index=129 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,alwout) - where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing - if(debugprint)print*,'sample l',VarName,' = ',1,alwout(im/2,(jsta+jend)/2) - -! time averaged outgoing model top longwave using gfsio - VarName='ulwrf' - VcoordName='nom. top' - Index=131 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,alwtoa) - if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(im/2,(jsta+jend)/2) - -! GFS does not have inst incoming sfc shortwave - rswin = spval - -! GFS does not have inst incoming clear sky sfc shortwave - rswinc = spval - -! GFS does not have inst outgoing sfc shortwave - rswout = spval - -! GFS incoming sfc longwave has been averaged, set ARDLW to 1 - ardsw = 1.0 -! trdsw=6.0 - -! time averaged incoming sfc shortwave using gfsio - Index=126 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,aswin) - if(debugprint)print*,'sample l',VarName,' = ',1,aswin(im/2,(jsta+jend)/2) - -! if(me==0 .and. iostatusFlux==0)then -! if(KPDS(13)==1)then -! TRDSW=float(KPDS(15)-KPDS(14)) -! else if(KPDS(13)==10)then -! TRDSW=float(KPDS(15)-KPDS(14))*3.0 -! else if(KPDS(13)==11)then -! TRDSW=float(KPDS(15)-KPDS(14))*6.0 -! else if(KPDS(13)==12)then -! TRDSW=float(KPDS(15)-KPDS(14))*12.0 -! else if(KPDS(13)==2)then -! TRDSW=float(KPDS(15)-KPDS(14))*24.0 -! else -! TRDSW=float(KPDS(15)-KPDS(14)) -! end if -! end if -! call mpi_bcast(trdsw,1,MPI_REAL,0,mpi_comm_comp,iret) -! print*,'TRDSW from flux grib massage= ',trdsw - -! time averaged incoming sfc uv-b using getgb - VarName='duvb' - VcoordName='sfc' - Index=298 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,auvbin) - if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(im/2,(jsta+jend)/2) - -! time averaged incoming sfc clear sky uv-b using getgb - VarName='cduvb' - VcoordName='sfc' - Index=297 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,auvbinc) - if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(im/2,(jsta+jend)/2) - -! time averaged outgoing sfc shortwave using gfsio - VarName='uswrf' - VcoordName='sfc' - Index=128 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,aswout) - where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing - if(debugprint)print*,'sample l',VarName,' = ',1,aswout(im/2,(jsta+jend)/2) - -! time averaged model top outgoing shortwave - VarName='uswrf' - VcoordName='nom. top' - Index=130 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,aswtoa) - if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(im/2,(jsta+jend)/2) - -! time averaged incoming clear sky sfc shortwave using getgb - Index=383 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - jpds(13)=3 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,aswinc) - -! time averaged outgoing clear sky sfc shortwave using getgb - Index=386 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - jpds(13)=3 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,aswoutc) - -! time averaged outgoing clear sky toa shortwave using getgb - Index=387 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - jpds(13)=3 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,aswtoac) - -! time averaged model top incoming shortwave - Index=388 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,aswintoa) - -! time averaged surface visible beam downward solar flux - Index=401 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,avisbeamswin) - -! time averaged surface visible diffuse downward solar flux - Index=402 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,avisdiffswin) - -! time averaged surface near IR beam downward solar flux - Index=403 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,airbeamswin) - -! time averaged surface near IR diffuse downward solar flux - Index=404 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,airdiffswin) - -! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux -! has reversed sign convention using gfsio - VarName='shtfl' - VcoordName='sfc' - Index=43 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sfcshx) - where (sfcshx /= spval)sfcshx=-sfcshx - if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(im/2,(jsta+jend)/2) - -! if(me==0 .and. iostatusFlux==0)then -! if(KPDS(13)==1)then -! TSRFC=float(KPDS(15)-KPDS(14)) -! else if(KPDS(13)==10)then -! TSRFC=float(KPDS(15)-KPDS(14))*3.0 -! else if(KPDS(13)==11)then -! TSRFC=float(KPDS(15)-KPDS(14))*6.0 -! else if(KPDS(13)==12)then -! TSRFC=float(KPDS(15)-KPDS(14))*12.0 -! else if(KPDS(13)==2)then -! TSRFC=float(KPDS(15)-KPDS(14))*24.0 -! else -! TSRFC=float(KPDS(15)-KPDS(14)) -! end if -! end if -! call mpi_bcast(tsrfc,1,MPI_REAL,0,mpi_comm_comp,iret) -! print*,'TSRFC from flux grib massage= ',tsrfc - -! GFS surface flux has been averaged, set ASRFC to 1 - asrfc=1.0 -! tsrfc=6.0 - -! time averaged surface latent heat flux, multiplied by -1 because wrf model flux -! has reversed sign vonvention using gfsio - Index=42 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sfclhx) - where (sfclhx /= spval)sfclhx=-sfclhx - if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(im/2,(jsta+jend)/2) - -! time averaged ground heat flux using nemsio - VarName='gflux' - VcoordName='sfc' - Index=135 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,subshx) - if(debugprint)print*,'sample l',VarName,' = ',1,subshx(im/2,(jsta+jend)/2) - -! GFS does not have snow phase change heat flux - snopcx=spval - -! time averaged zonal momentum flux using gfsio - VarName='uflx' - VcoordName='sfc' - Index=269 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sfcux) - if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(im/2,(jsta+jend)/2) - -! time averaged meridional momentum flux using nemsio - VarName='vflx' - VcoordName='sfc' - Index=270 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sfcvx) - if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(im/2,(jsta+jend)/2) - -! GFS does not use total momentum flux - sfcuvx=spval - -! time averaged zonal gravity wave stress using nemsio - VarName='u-gwd' - VcoordName='sfc' - Index=315 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sfcugs) - gtaux=sfcugs - if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(im/2,(jsta+jend)/2) - -! time averaged meridional gravity wave stress using getgb - VarName='v-gwd' - VcoordName='sfc' - Index=316 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sfcvgs) - gtauy=sfcvgs - if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(im/2,(jsta+jend)/2) - -! time averaged accumulated potential evaporation - VarName='pevpr' - VcoordName='sfc' - Index=242 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,potevp) - if(debugprint)print*,'sample l',VarName,' = ',1,potevp(im/2,(jsta+jend)/2) - -! GFS does not have temperature tendency due to long wave radiation - rlwtt=spval - -! GFS does not have temperature tendency due to solar radiation - rswtt=spval - -! GFS does not have temperature tendency due to latent heating from convection - tcucn=spval - tcucns=spval - -! set avrain to 1 - avrain=1.0 - avcnvc=1.0 - theat=6.0 ! just in case GFS decides to output T tendency - -! GFS does not have temperature tendency due to latent heating from grid scale - train=spval - -! 10 m u using nemsio - VarName='ugrd' - VcoordName='10 m above gnd' - Index=64 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=10 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,u10) - if(debugprint)print*,'sample l',VarName,' = ',1,u10(im/2,(jsta+jend)/2) - u10h=u10 -! 10 m v using gfsio - VarName='vgrd' - VcoordName='10 m above gnd' - Index=65 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=10 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,v10) - if(debugprint)print*,'sample l',VarName,' = ',1,v10(im/2,(jsta+jend)/2) - v10h=v10 -! GFS does not have soil moisture availability - smstav=spval - -! GFS does not have total soil moisture - smstot=spval - -! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='vgtyp' - VcoordName='sfc' - Index=218 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,buf) - where (buf /= spval) - ivgtyp=nint(buf) - elsewhere - ivgtyp=0 !need to feed reasonable value to crtm - end where - if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(im/2,(jsta+jend)/2) - -! soil type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='sotyp' - VcoordName='sfc' - Index=219 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,buf) - where (buf /= spval) - isltyp=nint(buf) - elsewhere - isltyp=0 !need to feed reasonable value to crtm - end where - if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(im/2,(jsta+jend)/2) - -! GFS does not have accumulated surface evaporation - sfcevp=spval - -! GFS does not have surface exchange coeefficient - sfcexc=spval - -! GFS does not have averaged accumulated snow - acsnow=spval - -! GFS does not have snow melt - acsnom=spval - -! GFS does not have sst???? - sst=spval - -! GFS does not have mixing length - EL_PBL=spval - -! GFS does not output exchange coefficient - exch_h=spval - -! GFS does not have THZ0, use THS to substitute - thz0=ths - if(debugprint)print*,'sample l',VarName,' = ',1,thz0(im/2,(jsta+jend)/2) - -! GFS does not output humidity at roughness length - qz0=spval - -! GFS does not output u at roughness length - uz0=spval - -! GFS does not output humidity at roughness length - vz0=spval - -! retrieve inst convective cloud top, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index - VarName='pres' - VcoordName='convect-cld top' - Index=189 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,ptop) - if(debugprint)print*,'sample l',VarName,' = ',1,ptop(im/2,(jsta+jend)/2) - - htop = spval - do j=jsta,jend - do i=1,im - if(ptop(i,j) <= 0.0) ptop(i,j) = spval - if(ptop(i,j) < spval) then - do l=1,lm - if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j) = l - exit - end if - end do - end if - end do - end do - if (me == 0) then - l = lm/2 - print*,'sample ptop,pmid pmid-1,pint= ', & - ptop(ii,jj),pmid(ii,jj,l),pmid(ii,jj,l-1),pint(ii,jj,l),htop(ii,jj) - endif - -! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index - VarName='pres' - VcoordName='convect-cld bot' - Index=188 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,pbot) - if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(im/2,(jsta+jend)/2) - - hbot = spval - do j=jsta,jend - do i=1,im - if(pbot(i,j) <= 0.0) pbot(i,j) = spval -! if(.not.lb(i,j))print*,'false bitmask for pbot at ' -! + ,i,j,pbot(i,j) - if(pbot(i,j) < spval)then - do l=lm,1,-1 - if(pbot(i,j) >= pmid(i,j,l))then - hbot(i,j) = l - exit - end if - end do - end if - end do - end do - print*,'sample pbot,pmid= ', pbot(ii,jj),pmid(ii,jj,l),hbot(ii,jj) - -! retrieve time averaged low cloud top pressure using nemsio - VarName='pres' - VcoordName='low cld top' - Index=304 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,ptopl) - if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(im/2,(jsta+jend)/2) - -! retrieve time averaged low cloud bottom pressure using nemsio - VarName='pres' - VcoordName='low cld bot' - Index=303 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,pbotl) - if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(im/2,(jsta+jend)/2) - -! retrieve time averaged low cloud top temperature using nemsio - VarName='tmp' - VcoordName='low cld top' - Index=305 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,Ttopl) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,Ttopl(im/2,(jsta+jend)/2) - -! retrieve time averaged middle cloud top pressure using nemsio - Index=307 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,ptopm) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,ptopm(im/2,(jsta+jend)/2) - -! retrieve time averaged middle cloud bottom pressure using nemsio - VarName='pres' - VcoordName='mid cld bot' - Index=306 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,pbotm) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,pbotm(im/2,(jsta+jend)/2) - -! retrieve time averaged middle cloud top temperature using nemsio - VarName='tmp' - VcoordName='mid cld top' - Index=308 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,Ttopm) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,Ttopm(im/2,(jsta+jend)/2) - -! retrieve time averaged high cloud top pressure using nemsio ********* - VarName='pres' - VcoordName='high cld top' - Index=310 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,ptoph) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,ptoph(im/2,(jsta+jend)/2) - -! retrieve time averaged high cloud bottom pressure using nemsio - VarName='pres' - VcoordName='high cld bot' - Index=309 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,pboth) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,pboth(im/2,(jsta+jend)/2) - -! retrieve time averaged high cloud top temperature using nemsio - VarName='tmp' - VcoordName='high cld top' - Index=311 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,Ttoph) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,Ttoph(im/2,(jsta+jend)/2) - -! retrieve boundary layer cloud cover using nemsio - VarName='tcdc' - VcoordName='bndary-layer cld' - Index=342 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,pblcfr) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,pblcfr(im/2,(jsta+jend)/2) - where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction - -! retrieve cloud work function using nemsio - Index=313 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cldwork) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,cldwork(im/2,(jsta+jend)/2) - -! retrieve water runoff using nemsio - VarName='watr' - VcoordName='sfc' - Index=343 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=0 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,runoff) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,runoff(im/2,(jsta+jend)/2) - -! retrieve shelter max temperature using nemsio - VarName='tmax' - VcoordName='2 m above gnd' - Index=345 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=2 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,maxtshltr) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,maxtshltr(im/2,(jsta+jend)/2) - -! retrieve shelter max temperature using nemsio - Index=346 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - jpds(7)=2 - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,mintshltr) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,mintshltr(im/2,(jsta+jend)/2) - - MAXRHSHLTR=SPVAL - MINRHSHLTR=SPVAL - -! bucket for max and min temperature and RH -! if(me==0 .and. iostatusFlux==0)then -! if(KPDS(13)==1)then -! TMAXMIN=float(KPDS(15)-KPDS(14)) -! else if(KPDS(13)==10)then -! TMAXMIN=float(KPDS(15)-KPDS(14))*3.0 -! else if(KPDS(13)==11)then -! TMAXMIN=float(KPDS(15)-KPDS(14))*6.0 -! else if(KPDS(13)==12)then -! TMAXMIN=float(KPDS(15)-KPDS(14))*12.0 -! else if(KPDS(13)==2)then -! TMAXMIN=float(KPDS(15)-KPDS(14))*24.0 -! else -! TMAXMIN=float(KPDS(15)-KPDS(14)) -! end if -! end if -! call mpi_bcast(TMAXMIN,1,MPI_REAL,0,mpi_comm_comp,iret) -! print*,'TMAXMIN from flux grib massage= ',TMAXMIN - -! retrieve ice thickness using nemsio - VarName='icetk' - VcoordName='sfc' - Index=349 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,dzice) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,dzice(im/2,(jsta+jend)/2) - -! retrieve wilting point using nemsio - VarName='wilt' - VcoordName='sfc' - Index=236 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,smcwlt) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,smcwlt(im/2,(jsta+jend)/2) - -! retrieve sunshine duration using nemsio - VarName='sunsd' - VcoordName='sfc' - Index=396 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,suntime) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,suntime(im/2,(jsta+jend)/2) - -! retrieve field capacity using nemsio - VarName='fldcp' - VcoordName='sfc' - Index=397 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,fieldcapa) - if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & - 1,fieldcapa(im/2,(jsta+jend)/2) - -! retrieve snowfall rate using getgb - Index=405 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,snowfall) - -! retrieve frozen precipitation fraction using getgb - Index=172 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - call getgbandscatter(me,iunit,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sr) - print*,'sampe GFS sr= ',sr(im/2,jsta) - -! GFS does not have deep convective cloud top and bottom fields - HTOPD = SPVAL - HBOTD = SPVAL - HTOPS = SPVAL - HBOTS = SPVAL - CUPPT = SPVAL - -!!!! DONE GETTING -! Will derive isobaric OMEGA from continuity equation later. -! OMGA=SPVAL -! retrieve d3d fields if it's listed - if (me == 0) print*,'iostatus for d3d file= ',iostatusD3D - if(iostatusD3D == 0) then ! start reading d3d file -! retrieve longwave tendency using getgb - Index=41 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - do l=1,lm - jpds(7)=l - ll = lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,rlwtt(1,jsta_2l,ll)) - end do - -! bucket for max and min temperature and RH -! if(me==0 .and. iostatusFlux==0)then -! if(KPDS(13)==1)then -! TD3D=float(KPDS(15)-KPDS(14)) -! else if(KPDS(13)==10)then -! TD3D=float(KPDS(15)-KPDS(14))*3.0 -! else if(KPDS(13)==11)then -! TD3D=float(KPDS(15)-KPDS(14))*6.0 -! else if(KPDS(13)==12)then -! TD3D=float(KPDS(15)-KPDS(14))*12.0 -! else if(KPDS(13)==2)then -! TD3D=float(KPDS(15)-KPDS(14))*24.0 -! else -! TD3D=float(KPDS(15)-KPDS(14)) -! end if -! end if -! call mpi_bcast(TD3D,1,MPI_REAL,0,mpi_comm_comp,iret) -! print*,'TD3D from D3D grib massage= ',TD3D - -! retrieve shortwave tendency using getgb - Index=40 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - do l=1,lm - jpds(7)=l - ll = lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,rswtt(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion tendency using getgb - Index=356 - VarName='VDIFF TNDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll = lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdifftt(1,jsta_2l,ll)) - end do - -! retrieve deep convective tendency using getgb - Index=79 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,tcucn(1,jsta_2l,ll)) - end do - -! retrieve shallow convective tendency using getgb - Index=358 - VarName='S CNVCT TNDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,tcucns(1,jsta_2l,ll)) - end do - -! retrieve grid scale latent heat tendency using getgb - Index=78 - VarName=avbl(index) - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=is(index) - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,train(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion moistening using getgb - Index=360 - VarName='Vertical diffusion moistening' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdiffmois(1,jsta_2l,ll)) - end do - -! retrieve deep convection moistening using getgb - Index=361 - VarName='deep convection moistening' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,dconvmois(1,jsta_2l,ll)) - end do - -! retrieve shallow convection moistening using getgb - Index=362 - VarName='shallow convection moistening' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sconvmois(1,jsta_2l,ll)) - end do - -! retrieve non-radiation tendency using getgb - Index=363 - VarName='non-radiation tendency' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,nradtt(1,jsta_2l,ll)) - end do - -! retrieve Vertical diffusion of ozone using getgb - Index=364 - VarName='Vertical diffusion of ozone' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,o3vdiff(1,jsta_2l,ll)) - end do - -! retrieve ozone production using getgb - Index=365 - VarName='Ozone production' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,o3prod(1,jsta_2l,ll)) - end do - -! retrieve ozone tendency using getgb - Index=366 - VarName='Ozone tendency' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,o3tndy(1,jsta_2l,ll)) - end do - -! retrieve mass weighted PV using getgb - Index=367 - VarName='Mass weighted PV' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,mwpv(1,jsta_2l,ll)) - end do - -! retrieve OZONE TNDY using getgb - Index=368 - VarName='?' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,unknown(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion zonal acceleration - Index=369 - VarName='VDIFF Z ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdiffzacce(1,jsta_2l,ll)) - end do - -! retrieve gravity drag zonal acceleration - Index=370 - VarName='G DRAG Z ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,zgdrag(1,jsta_2l,ll)) - end do - -! retrieve convective U momemtum mixing - Index=371 - VarName='CNVCT U M MIX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctummixing(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion meridional acceleration - Index=372 - VarName='VDIFF M ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdiffmacce(1,jsta_2l,ll)) - end do - -! retrieve gravity drag meridional acceleration - Index=373 - VarName='G DRAG M ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,mgdrag(1,jsta_2l,ll)) - end do - -! retrieve convective V momemtum mixing - Index=374 - VarName='CNVCT V M MIX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctvmmixing(1,jsta_2l,ll)) - end do - -! retrieve nonconvective cloud fraction - Index=375 - VarName='N CNVCT CLD FRA' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,ncnvctcfrac(1,jsta_2l,ll)) - end do - -! retrieve convective upward mass flux - Index=391 - VarName='CNVCT U M FLX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctumflx(1,jsta_2l,ll)) - end do - -! retrieve convective downward mass flux - Index=392 - VarName='CNVCT D M FLX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctdmflx(1,jsta_2l,ll)) - end do - -! retrieve nonconvective detraintment flux - Index=393 - VarName='CNVCT DET M FLX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctdetmflx(1,jsta_2l,ll)) - end do - -! retrieve cnvct gravity drag zonal acceleration - Index=394 - VarName='CNVCT G DRAG Z ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctzgdrag(1,jsta_2l,ll)) - end do - -! retrieve cnvct gravity drag meridional acceleration - Index=395 - VarName='CNVCT G DRAG M ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=iq(index) - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctmgdrag(1,jsta_2l,ll)) - end do - - call baclose(iunitd3d,status) - if (me == 0) print*,'done reading D3D fields' - end if ! end of d3d file read - if (me == 0) print *,'after d3d files reading,mype=',me -! pos east - call collect_loc(gdlat,dummy) - if(me == 0) then - latstart=nint(dummy(1,1)*gdsdegr) - latlast=nint(dummy(im,jm)*gdsdegr) - print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,& - 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1) - end if - call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me - call collect_loc(gdlon,dummy) - if(me==0)then - lonstart=nint(dummy(1,1)*gdsdegr) - lonlast=nint(dummy(im,jm)*gdsdegr) - end if - call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(lonlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast -! -! ncdump -h - -!! -!! -!! - write(6,*) 'filename in INITPOST=', filename,' is' - -! status=nf_open(filename,NF_NOWRITE,ncid) -! write(6,*) 'returned ncid= ', ncid -! status=nf_get_att_real(ncid,varid,'DX',tmp) -! dxval=int(tmp) -! status=nf_get_att_real(ncid,varid,'DY',tmp) -! dyval=int(tmp) -! status=nf_get_att_real(ncid,varid,'CEN_LAT',tmp) -! cenlat=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'CEN_LON',tmp) -! cenlon=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'TRUELAT1',tmp) -! truelat1=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'TRUELAT2',tmp) -! truelat2=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'MAP_PROJ',tmp) -! maptype=int(tmp) -! status=nf_close(ncid) - -! dxval=30000. -! dyval=30000. -! -! write(6,*) 'dxval= ', dxval -! write(6,*) 'dyval= ', dyval -! write(6,*) 'cenlat= ', cenlat -! write(6,*) 'cenlon= ', cenlon -! write(6,*) 'truelat1= ', truelat1 -! write(6,*) 'truelat2= ', truelat2 -! write(6,*) 'maptype is ', maptype -! - -! close up shop -! call ext_int_ioclose ( DataHandle, Status ) - -! generate look up table for lifted parcel calculations - - THL = 210. - PLQ = 70000. - -! write(0,*)' bef TABLE PT=',PT,' THL=',THL - CALL TABLE(PTBL,TTBL,PT, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - - -! write(0,*)'end ini_gfs_sigio' -! -! - IF(ME==0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -! COMPUTE DERIVED TIME STEPPING CONSTANTS. -! -!MEB need to get DT -! DT = 120. !MEB need to get DT -! NPHS = 4 !MEB need to get physics DT -! TPREC=float(ifhr) -!MEB need to get DT - -!how am i going to get this information? -! NPREC = INT(TPREC *TSPH+D50) -! NHEAT = INT(THEAT *TSPH+D50) -! NCLOD = INT(TCLOD *TSPH+D50) -! NRDSW = INT(TRDSW *TSPH+D50) -! NRDLW = INT(TRDLW *TSPH+D50) -! NSRFC = INT(TSRFC *TSPH+D50) -!how am i going to get this information? -! -! IF(ME==0)THEN -! WRITE(6,*)' ' -! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS' -! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC -! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW -! ENDIF -! -! COMPUTE DERIVED MAP OUTPUT CONSTANTS. - DO L = 1,LSM - ALSL(L) = LOG(SPL(L)) - END DO -! -!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - if(me==0)then - print*,'writing out igds' - igdout=110 -! open(igdout,file='griddef.out',form='unformatted' -! + ,status='unknown') - if(maptype == 1)THEN ! Lambert conformal - WRITE(igdout)3 - WRITE(6,*)'igd(1)=',3 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ELSE IF(MAPTYPE == 2)THEN !Polar stereographic - WRITE(igdout)5 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 !Assume projection at +-90 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ELSE IF(MAPTYPE == 3)THEN !Mercator - WRITE(igdout)1 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)latlast - WRITE(igdout)lonlast - WRITE(igdout)TRUELAT1 - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)255 - ELSE IF(MAPTYPE==0 .OR. MAPTYPE==203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - END IF - end if -! -! close all files - - call baclose(iunit,status) - - deallocate(dummy) - - RETURN - END - - 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 From 50f11eb5cb89066f3f5faf3d61e28cf801f5ad66 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Fri, 17 Sep 2021 19:42:40 +0000 Subject: [PATCH 33/77] 20210917 Jesse Meng remove legacy code SLP_NMM EXCH2 --- sorc/ncep_post.fd/CMakeLists.txt | 2 -- sorc/ncep_post.fd/MDL2P.f | 2 +- sorc/ncep_post.fd/makefile_dtc | 4 ++-- sorc/ncep_post.fd/makefile_lib | 4 ++-- sorc/ncep_post.fd/makefile_module | 4 ++-- 5 files changed, 7 insertions(+), 9 deletions(-) diff --git a/sorc/ncep_post.fd/CMakeLists.txt b/sorc/ncep_post.fd/CMakeLists.txt index 20b438d94..b97dd6964 100644 --- a/sorc/ncep_post.fd/CMakeLists.txt +++ b/sorc/ncep_post.fd/CMakeLists.txt @@ -46,7 +46,6 @@ list(APPEND LIB_SRC DEWPOINT.f ETCALC.f ETAMP_Q2F.f - EXCH2.f EXCH.f FDLVL.f FGAMMA.f @@ -116,7 +115,6 @@ list(APPEND LIB_SRC SET_OUTFLDS.f SETUP_SERVERS.f SLP_new.f - SLP_NMM.f SMOOTH.f SNFRAC.f SNFRAC_GFS.f diff --git a/sorc/ncep_post.fd/MDL2P.f b/sorc/ncep_post.fd/MDL2P.f index b63674018..bf761b170 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -3849,7 +3849,7 @@ SUBROUTINE MDL2P(iostatusD3D) maxval(pslp(ista:iend,jsta:jend)),minval(pslp(ista:iend,jsta:jend)),pslp((ista+iend)/2,(jsta+jend)/2) ELSE IF (gridtype == 'E')THEN if(me==0)PRINT*,'CALLING MEMSLP_NMM for E grid' - CALL MEMSLP_NMM(TPRS,QPRS,FPRS) +! CALL MEMSLP_NMM(TPRS,QPRS,FPRS) ELSE PRINT*,'unknow grid type-> WONT DERIVE MESINGER SLP' END IF diff --git a/sorc/ncep_post.fd/makefile_dtc b/sorc/ncep_post.fd/makefile_dtc index 519c2418b..421670445 100644 --- a/sorc/ncep_post.fd/makefile_dtc +++ b/sorc/ncep_post.fd/makefile_dtc @@ -67,8 +67,8 @@ OBJS_F = VRBLS2D_mod.o VRBLS3D_mod.o VRBLS4D_mod.o MASKS_mod.o PMICRPH.o SOIL_m CALWXT_DOMINANT.o CLDRAD.o \ CLMAX.o COLLECT.o COLLECT_LOC.o DEWPOINT.o FDLVL.o FGAMMA.o FIXED.o FRZLVL.o FRZLVL2.o \ GET_BITS.o INITPOST.o LFMFLD.o MAPSSLP.o MISCLN.o MDL2STD_P.o MIXLEN.o MDL2P.o ETAMP_Q2F.o \ - MDLFLD.o MPI_FIRST.o MPI_LAST.o NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o SLP_NMM.o \ - EXCH.o PARA_RANGE.o PROCESS.o INITPOST_NMM.o EXCH2.o READCNTRL.o READ_xml.o \ + MDLFLD.o MPI_FIRST.o MPI_LAST.o NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o \ + EXCH.o PARA_RANGE.o PROCESS.o INITPOST_NMM.o READCNTRL.o READ_xml.o \ SET_OUTFLDS.o SCLFLD.o SERVER.o \ SETUP_SERVERS.o SMOOTH.o SURFCE.o SPLINE.o TABLE.o TABLEQ.o TRPAUS.o TTBLEX.o WETBULB.o \ WRFPOST.o CALMICT.o MICROINIT.o GPVS.o MDL2SIGMA.o ETCALC.o CANRES.o \ diff --git a/sorc/ncep_post.fd/makefile_lib b/sorc/ncep_post.fd/makefile_lib index 37d48af6e..89864e3de 100644 --- a/sorc/ncep_post.fd/makefile_lib +++ b/sorc/ncep_post.fd/makefile_lib @@ -102,8 +102,8 @@ OBJS= VRBLS2D_mod.o VRBLS3D_mod.o VRBLS4D_mod.o MASKS_mod.o PMICRPH.o SOIL_mod.o FDLVL.o FGAMMA.o FIXED.o FRZLVL.o FRZLVL2.o \ GET_BITS.o LFMFLD.o \ MAPSSLP.o MISCLN.o MDL2STD_P.o MIXLEN.o MDL2P.o MDLFLD.o \ - NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o SLP_NMM.o EXCH.o \ - PARA_RANGE.o PROCESS.o EXCH2.o \ + NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o EXCH.o \ + PARA_RANGE.o PROCESS.o \ READCNTRL.o READ_xml.o SET_OUTFLDS.o SCLFLD.o \ SMOOTH.o SURFCE.o \ SPLINE.o TABLE.o TABLEQ.o TRPAUS.o TTBLEX.o WETBULB.o \ diff --git a/sorc/ncep_post.fd/makefile_module b/sorc/ncep_post.fd/makefile_module index 5b6f2c763..649440672 100644 --- a/sorc/ncep_post.fd/makefile_module +++ b/sorc/ncep_post.fd/makefile_module @@ -82,8 +82,8 @@ OBJS = wrf_io_flags.o getVariable.o getIVariableN.o \ FDLVL.o FGAMMA.o FIXED.o FRZLVL.o FRZLVL2.o \ GET_BITS.o INITPOST.o LFMFLD.o \ MAPSSLP.o MISCLN.o MDL2STD_P.o MIXLEN.o MDL2P.o MDLFLD.o MPI_FIRST.o MPI_LAST.o \ - NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o SLP_NMM.o EXCH.o \ - PARA_RANGE.o PROCESS.o INITPOST_NMM.o EXCH2.o \ + NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o EXCH.o \ + PARA_RANGE.o PROCESS.o INITPOST_NMM.o \ READCNTRL.o READ_xml.o SET_OUTFLDS.o SCLFLD.o SERVER.o SETUP_SERVERS.o \ SMOOTH.o SURFCE.o \ SPLINE.o TABLE.o TABLEQ.o TRPAUS.o TTBLEX.o WETBULB.o WRFPOST.o \ From fa8b9cebf56385a340bf3f3b1fef1ca2bdb0d484 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Fri, 17 Sep 2021 19:53:41 +0000 Subject: [PATCH 34/77] 20210917 Jesse Meng remove legacy code INITPOST_GFS_SIGIO.f INITPOST_GFS_NEMS.f --- sorc/ncep_post.fd/CMakeLists.txt | 2 -- 1 file changed, 2 deletions(-) diff --git a/sorc/ncep_post.fd/CMakeLists.txt b/sorc/ncep_post.fd/CMakeLists.txt index b97dd6964..fa73379fe 100644 --- a/sorc/ncep_post.fd/CMakeLists.txt +++ b/sorc/ncep_post.fd/CMakeLists.txt @@ -141,11 +141,9 @@ list(APPEND EXE_SRC GETNEMSNDSCATTER.f GFSPOSTSIG.F INITPOST.F - INITPOST_GFS_NEMS.f INITPOST_GFS_NEMS_MPIIO.f INITPOST_GFS_NETCDF.f INITPOST_GFS_NETCDF_PARA.f - INITPOST_GFS_SIGIO.f INITPOST_NEMS.f INITPOST_NEMS_MPIIO.f INITPOST_NETCDF.f From 3f464b2bb92f70f215f2d76608d1fd2140e6c2f6 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Fri, 17 Sep 2021 21:14:09 +0000 Subject: [PATCH 35/77] 20210917 Jesse Meng add INITPOST_GFS_NEMS.f back to avoid compiling error. --- sorc/ncep_post.fd/CMakeLists.txt | 1 + sorc/ncep_post.fd/INITPOST_GFS_NEMS.f | 3265 +++++++++++++++++++++++++ sorc/ncep_post.fd/WRFPOST.f | 6 +- sorc/ncep_post.fd/makefile_dtc | 4 +- sorc/ncep_post.fd/makefile_module | 4 +- 5 files changed, 3273 insertions(+), 7 deletions(-) create mode 100644 sorc/ncep_post.fd/INITPOST_GFS_NEMS.f diff --git a/sorc/ncep_post.fd/CMakeLists.txt b/sorc/ncep_post.fd/CMakeLists.txt index fa73379fe..148517677 100644 --- a/sorc/ncep_post.fd/CMakeLists.txt +++ b/sorc/ncep_post.fd/CMakeLists.txt @@ -141,6 +141,7 @@ list(APPEND EXE_SRC GETNEMSNDSCATTER.f GFSPOSTSIG.F INITPOST.F + INITPOST_GFS_NEMS.f INITPOST_GFS_NEMS_MPIIO.f INITPOST_GFS_NETCDF.f INITPOST_GFS_NETCDF_PARA.f diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f b/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f new file mode 100644 index 000000000..7111fb628 --- /dev/null +++ b/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f @@ -0,0 +1,3265 @@ +!> @file +! . . . +!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN +!! PRGRMMR: Hui-Ya Chuang DATE: 2007-03-01 +!! +!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND +!! VARIABLES AT THE START OF GFS MODEL OR POST +!! PROCESSOR RUN. +!! +!! REVISION HISTORY +!! 2011-02-07 Jun Wang add grib2 option +!! 2011-12-14 Sarah Lu add aer option +!! 2012-01-07 Sarah Lu compute air density +!! 2012-12-22 Sarah Lu add aerosol zerout option +!! 2015-03-16 S. Moorthi adding gocart_on option +!! 2015-03-18 S. Moorthi Optimization including threading +!! 2015-08-17 S. Moorthi Add TKE for NEMS/GSM +!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) +!! +!! USAGE: CALL INIT +!! INPUT ARGUMENT LIST: +!! NONE +!! +!! OUTPUT ARGUMENT LIST: +!! NONE +!! +!! OUTPUT FILES: +!! NONE +!! +!! SUBPROGRAMS CALLED: +!! UTILITIES: +!! NONE +!! LIBRARY: +!! COMMON - CTLBLK +!! LOOKUP +!! SOILDEPTH +!! +!! +!! ATTRIBUTES: +!! LANGUAGE: FORTRAN +!! MACHINE : CRAY C-90 +!! + SUBROUTINE INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D, & + iostatusAER,nfile,ffile,rfile) +! SUBROUTINE INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,nfile,ffile) + + + use vrbls4d, only: dust, SALT, SUSO, SOOT, WASO + use vrbls3d, only: t, q, uh, vh, pmid, pint, alpint, dpres, zint, zmid, o3, & + qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, & + tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, & + o3vdiff, o3prod, o3tndy, mwpv, unknown, vdiffzacce, zgdrag,cnvctummixing, & + vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, & + cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp + use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, & + cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, & + tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, radot, sigt4, & + cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, & + islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, & + bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, & + rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, & + snopcx, sfcux, sfcvx, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, & + smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, & + uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, & + ptoph, pboth, pblcfr, ttoph, runoff, maxtshltr, mintshltr, maxrhshltr, & + minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, & + cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa, & + u10h,v10h + use soil, only: sldpth, sh2o, smc, stc + use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice +! use kinds, only: i_llong + use nemsio_module, only: nemsio_gfile, nemsio_getfilehead, nemsio_getheadvar, nemsio_close + use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, & + eps => con_eps, epsm1 => con_epsm1 + use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa + use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, & + ttblq, rdpq, rdtheq, stheq, the0q, the0 + use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, & + ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, & + jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,& + ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, & + jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, & + nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp + use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, & + dxval, dyval, truelat2, truelat1, psmapf, cenlat + use rqstfld_mod, only: igds, avbl, iq, is + use upp_physics, only: fpvsnew +! use wrf_io_flags_mod, only: ! Do we need this? +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! + type(nemsio_gfile),intent(inout) :: nfile,ffile,rfile +! +! INCLUDE/SET PARAMETERS. +! + INCLUDE "mpif.h" + +! integer,parameter:: MAXPTS=1000000 ! max im*jm points +! +! real,parameter:: con_g =9.80665e+0! gravity +! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O +! real,parameter:: con_rd =2.8705e+2 ! gas constant air +! real,parameter:: con_fvirt =con_rv/con_rd-1. +! real,parameter:: con_eps =con_rd/con_rv +! real,parameter:: con_epsm1 =con_rd/con_rv-1 +! +! This version of INITPOST shows how to initialize, open, read from, and +! close a NetCDF dataset. In order to change it to read an internal (binary) +! dataset, do a global replacement of _ncd_ with _int_. + + real, parameter :: gravi = 1.0/grav + integer,intent(in) :: NREC,iostatusFlux,iostatusD3D,iostatusAER + character(len=20) :: VarName, VcoordName + integer :: Status + character startdate*19,SysDepInfo*80,cgar*1 + character startdate2(19)*4 +! +! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK +! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. +! +! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE +! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. + LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL + logical, parameter :: debugprint = .false., zerout = .false. +! logical, parameter :: debugprint = .true., zerout = .false. + CHARACTER*32 LABEL + CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC + CHARACTER*4 RESTHR + CHARACTER FNAME*255,ENVAR*50 + INTEGER IDATE(8),JDATE(8),JPDS(200),JGDS(200),KPDS(200),KGDS(200) +! LOGICAL*1 LB(IM,JM) +! +! INCLUDE COMMON BLOCKS. +! +! DECLARE VARIABLES. +! +! REAL fhour + integer nfhour ! forecast hour from nems io file + REAL RINC(5) + + REAL DUMMY(IM,JM), DUMMY2(IM,JM) + real, allocatable :: fi(:,:,:) +!jw + integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, & + I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, & + impf,jmpf,nframed2,iunitd3d,ierr,idum,iret + real TSTART,TLMH,TSPH,ES,FACT,soilayert,soilayerb,zhour,dum, & + tvll,pmll,tv + + character*8, allocatable :: recname(:) + character*16,allocatable :: reclevtyp(:) + integer, allocatable :: reclev(:) + real, allocatable :: glat1d(:), glon1d(:), qstl(:) + real, allocatable :: wrk1(:,:), wrk2(:,:) + real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), & + qs2d(:,:), cw2d(:,:), cfr2d(:,:) + real(kind=4),allocatable :: vcoord4(:,:,:) + real, dimension(lm+1) :: ak5, bk5 + real*8, allocatable :: pm2d(:,:), pi2d(:,:) + + real buf(im,jsta_2l:jend_2u) + +! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & +! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) + + real LAT, isa, jsa +! REAL, PARAMETER :: QMIN = 1.E-15 + +! DATA BLANK/' '/ +! +!*********************************************************************** +! START INIT HERE. +! + WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NEMS' + WRITE(6,*)'me=',me,'LMV=',size(LMV,1),size(LMV,2),'LMH=', & + size(LMH,1),size(LMH,2),'jsta_2l=',jsta_2l,'jend_2u=', & + jend_2u,'im=',im +! + isa = im / 2 + jsa = (jsta+jend) / 2 + +!$omp parallel do private(i,j) + do j = jsta_2l, jend_2u + do i=1,im + buf(i,j) = spval + enddo + enddo +! +! STEP 1. READ MODEL OUTPUT FILE +! +! +!*** +! +! LMH and LMV always = LM for sigma-type vert coord + +!$omp parallel do private(i,j) + do j = jsta_2l, jend_2u + do i = 1, im + LMV(i,j) = lm + LMH(i,j) = lm + end do + end do + +! HTM VTM all 1 for sigma-type vert coord + +!$omp parallel do private(i,j,l) + do l = 1, lm + do j = jsta_2l, jend_2u + do i = 1, im + HTM (i,j,l) = 1.0 + VTM (i,j,l) = 1.0 + end do + end do + end do +! +! how do I get the filename? +! fileName = '/ptmp/wx20mb/wrfout_01_030500' +! DateStr = '2002-03-05_18:00:00' +! how do I get the filename? +! call ext_int_ioinit(SysDepInfo,Status) +! print*,'called ioinit', Status +! call ext_int_open_for_read( trim(fileName), 0, 0, " ", +! & DataHandle, Status) +! print*,'called open for read', Status +! if ( Status /= 0 ) then +! print*,'error opening ',fileName, ' Status = ', Status ; stop +! endif +! get date/time info +! this routine will get the next time from the file, not using it +! print *,'DateStr before calling ext_int_get_next_time=',DateStr +! call ext_int_get_next_time(DataHandle, DateStr, Status) +! print *,'DateStri,Status,DataHandle = ',DateStr,Status,DataHandle + +! The end j row is going to be jend_2u for all variables except for V. + + JS = JSTA_2L + JE = JEND_2U + +! get start date + if (me == 0)then + print*,'nrec=',nrec + allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) + allocate(glat1d(im*jm),glon1d(im*jm)) + allocate(vcoord4(lm+1,3,2)) + call nemsio_getfilehead(nfile,iret=iret & + ,idate=idate(1:7),nfhour=nfhour,recname=recname & + ,reclevtyp=reclevtyp,reclev=reclev,lat=glat1d & + ,lon=glon1d,nframe=nframe,vcoord=vcoord4) + if(iret/=0)print*,'error getting idate,nfhour' + print *,'latstar1=',glat1d(1),glat1d(im*jm) +! print *,'printing an inventory of GFS nemsio file' +! do i=1,nrec +! print *,'recname=',(trim(recname(i))) +! print *,'reclevtyp=',(trim(reclevtyp(i))) +! print *,'reclev=',(reclev(i)) +! end do +! deallocate (recname,reclevtyp,reclev) + +! call nemsio_getfilehead(ffile,nrec=idum) +! print*,'nrec for flux file = ',idum +! allocate(recname(idum),reclevtyp(idum),reclev(idum)) +! call nemsio_getfilehead(ffile,iret=iret, & +! recname=recname,reclevtyp=reclevtyp,reclev=reclev) +! do i=1,idum +! print *,'recname=',(trim(recname(i))) +! print *,'reclevtyp=',(trim(reclevtyp(i))) +! print *,'reclev=',(reclev(i)) +! end do + +!$omp parallel do private(i,j) + do j=1,jm + do i=1,im + dummy(i,j) = glat1d((j-1)*im+i) + dummy2(i,j) = glon1d((j-1)*im+i) + end do + end do +! + if (hyb_sigp) then + do l=1,lm+1 + ak5(l) = vcoord4(l,1,1) + bk5(l) = vcoord4(l,2,1) + enddo + endif +! + deallocate(recname,reclevtyp,reclev,glat1d,glon1d,vcoord4) +! can't get idate and fhour, specify them for now +! idate(4)=2006 +! idate(2)=9 +! idate(3)=16 +! idate(1)=0 +! fhour=6.0 + print*,'idate before broadcast = ',(idate(i),i=1,7) + end if + call mpi_bcast(idate(1), 7, MPI_INTEGER, 0, mpi_comm_comp, iret) + call mpi_bcast(nfhour, 1, MPI_INTEGER, 0, mpi_comm_comp, iret) + call mpi_bcast(nframe, 1, MPI_INTEGER, 0, mpi_comm_comp, iret) + print*,'idate after broadcast = ',(idate(i),i=1,4) + print*,'nfhour = ',nfhour + + if (hyb_sigp) then + call mpi_bcast(ak5, lm+1, MPI_REAL, 0, mpi_comm_comp, iret) + call mpi_bcast(bk5, lm+1, MPI_REAL, 0, mpi_comm_comp, iret) + endif + if (me == 0) print *,' ak5=',ak5 + if (me == 0) print *,' bk5=',bk5 + +! sample print point + ii = im/2 + jj = jm/2 + call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & + ,gdlat(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,ierr) + call mpi_scatterv(dummy2(1,1),icnt,idsp,mpi_real & + ,gdlon(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,ierr) + + print *,'before call EXCH,mype=',me,'max(gdlat)=',maxval(gdlat), & + 'max(gdlon)=', maxval(gdlon) + CALL EXCH(gdlat(1,JSTA_2L)) + print *,'after call EXCH,mype=',me + +!$omp parallel do private(i,j) + do j = jsta, jend_m + do i = 1, im-1 + DX (i,j) = ERAD*COS(GDLAT(I,J)*DTR) *(GDLON(I+1,J)-GDLON(I,J))*DTR + DY (i,j) = ERAD*(GDLAT(I,J)-GDLAT(I,J+1))*DTR ! like A*DPH +! F(I,J)=1.454441e-4*sin(gdlat(i,j)*DTR) ! 2*omeg*sin(phi) +! if (i == ii .and. j == jj) print*,'sample LATLON, DY, DY=' & +! ,i,j,GDLAT(I,J),GDLON(I,J),DX(I,J),DY(I,J) + end do + end do + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + F(I,J) = 1.454441e-4*sin(gdlat(i,j)*DTR) ! 2*omeg*sin(phi) + end do + end do + + impf = im + jmpf = jm + print*,'impf,jmpf,nframe= ',impf,jmpf,nframe + +!MEB not sure how to get these + ! waiting to read in lat lon from GFS soon +! varname='GLAT' +! call retrieve_index(index,VarName,varname_all,nrecs,iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! GDLAT=SPVAL +! else +! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im +! this_length=im*(jend_2u-jsta_2l+1) +! call mpi_file_read_at(iunit,this_offset +! + ,buf,this_length,mpi_real4 +! + , mpi_status_ignore, ierr) +! if (ierr /= 0) then +! print*,"Error reading ", VarName,"Assigned missing values" +! GDLAT=SPVAL +! else +! do j = jsta_2l, jend_2u +! do i = 1, im +! F(I,J)=1.454441e-4*sin(buf(I,J)) ! 2*omeg*sin(phi) +! GDLAT(I,J)=buf(I,J)*RTD + +! enddo +! enddo +! end if +! end if + +! varname='GLON' +! call retrieve_index(index,VarName,varname_all,nrecs,iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! GDLON=SPVAL +! else +! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im +! this_length=im*(jend_2u-jsta_2l+1) +! call mpi_file_read_at(iunit,this_offset +! + ,buf,this_length,mpi_real4 +! + , mpi_status_ignore, ierr) +! if (ierr /= 0) then +! print*,"Error reading ", VarName,"Assigned missing values" +! GDLON=SPVAL +! else +! do j = jsta_2l, jend_2u +! do i = 1, im +! GDLON(I,J)=buf(I,J)*RTD +! if(i == 409.and.j == 835)print*,'GDLAT GDLON in INITPOST=' +! + ,i,j,GDLAT(I,J),GDLON(I,J) +! enddo +! enddo +! end if +! end if + +! if(jsta<=594.and.jend>=594)print*,'gdlon(120,594)= ', +! + gdlon(120,594) + + +! iyear=idate(4)+2000 ! older gfsio only has 2 digit year + iyear = idate(1) + imn = idate(2) ! ask Jun + iday = idate(3) ! ask Jun + ihrst = idate(4) + imin = idate(5) + jdate = 0 + idate = 0 +! +! read(startdate,15)iyear,imn,iday,ihrst,imin + 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2) + print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin + print*,'processing yr mo day hr min=' & + ,idat(3),idat(1),idat(2),idat(4),idat(5) +! + idate(1) = iyear + idate(2) = imn + idate(3) = iday + idate(5) = ihrst + idate(6) = imin + SDAT(1) = imn + SDAT(2) = iday + SDAT(3) = iyear + jdate(1) = idat(3) + jdate(2) = idat(1) + jdate(3) = idat(2) + jdate(5) = idat(4) + jdate(6) = idat(5) +! + print *,' idate=',idate + print *,' jdate=',jdate +! CALL W3DIFDAT(JDATE,IDATE,2,RINC) +! ifhr=nint(rinc(2)) +! + CALL W3DIFDAT(JDATE,IDATE,0,RINC) +! + print *,' rinc=',rinc + ifhr = nint(rinc(2)+rinc(1)*24.) + print *,' ifhr=',ifhr + ifmin = nint(rinc(3)) +! if(ifhr /= nint(fhour))print*,'find wrong Grib file';stop + print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,fileName + +! GFS has the same accumulation bucket for precipitation and fluxes and it is written to header +! the header has the start hour information so post uses it to recontruct bucket + if(me==0)then + call nemsio_getheadvar(ffile,'zhour',zhour,iret=iret) + if(iret==0)then + tprec = 1.0*ifhr-zhour + tclod = tprec + trdlw = tprec + trdsw = tprec + tsrfc = tprec + tmaxmin = tprec + td3d = tprec + print*,'tprec from flux file header= ',tprec + else + print*,'Error reading accumulation bucket from flux file', & + 'header - will try to read from env variable FHZER' + CALL GETENV('FHZER',ENVAR) + read(ENVAR, '(I2)')idum + tprec = idum*1.0 + tclod = tprec + trdlw = tprec + trdsw = tprec + tsrfc = tprec + tmaxmin = tprec + td3d = tprec + print*,'TPREC from FHZER= ',tprec + end if + end if + + call mpi_bcast(tprec, 1,MPI_REAL,0,mpi_comm_comp,iret) + call mpi_bcast(tclod, 1,MPI_REAL,0,mpi_comm_comp,iret) + call mpi_bcast(trdlw, 1,MPI_REAL,0,mpi_comm_comp,iret) + call mpi_bcast(trdsw, 1,MPI_REAL,0,mpi_comm_comp,iret) + call mpi_bcast(tsrfc, 1,MPI_REAL,0,mpi_comm_comp,iret) + call mpi_bcast(tmaxmin,1,MPI_REAL,0,mpi_comm_comp,iret) + call mpi_bcast(td3d, 1,MPI_REAL,0,mpi_comm_comp,iret) + +! Getting tstart + tstart=0. +! VarName='TSTART' +! call retrieve_index(index,VarName,varname_all,nrecs,iret) +! if (iret /= 0) then +! print*,VarName," not found in file" +! else +! call mpi_file_read_at(iunit,file_offset(index)+5*4 +! + ,garb,1,mpi_real4 +! + , mpi_status_ignore, ierr) +! if (ierr /= 0) then +! print*,"Error reading ", VarName," using MPIIO" +! else +! print*,VarName, ' from MPIIO READ= ',garb +! tstart=garb +! end if +! end if + print*,'tstart= ',tstart + +! Getiing restart + + RESTRT=.TRUE. ! set RESTRT as default +! call ext_int_get_dom_ti_integer(DataHandle,'RESTARTBIN',itmp +! + ,1,ioutcount,istatus) + +! IF(itmp < 1)THEN +! RESTRT=.FALSE. +! ELSE +! RESTRT=.TRUE. +! END IF + +! print*,'status for getting RESTARTBIN= ',istatus + +! print*,'Is this a restrt run? ',RESTRT + + IF(tstart > 1.0E-2)THEN + ifhr = ifhr+NINT(tstart) + rinc = 0 + idate = 0 + rinc(2) = -1.0*ifhr + call w3movdat(rinc,jdate,idate) + SDAT(1) = idate(2) + SDAT(2) = idate(3) + SDAT(3) = idate(1) + IHRST = idate(5) + print*,'new forecast hours for restrt run= ',ifhr + print*,'new start yr mo day hr min =',sdat(3),sdat(1) & + ,sdat(2),ihrst,imin + END IF + + imp_physics = 99 !set GFS mp physics to 99 for Zhao scheme + print*,'MP_PHYSICS= ',imp_physics + +! Initializes constants for Ferrier microphysics + if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then + CALL MICROINIT(imp_physics) + end if + +! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD + VarName='IVEGSRC' + if(me == 0)then + call nemsio_getheadvar(nfile,trim(VarName),IVEGSRC,iret) + if (iret /= 0) then + print*,VarName,' not found in file-Assigned 2 for UMD as default' + IVEGSRC=1 + end if + end if + call mpi_bcast(IVEGSRC,1,MPI_INTEGER,0,mpi_comm_comp,iret) + print*,'IVEGSRC= ',IVEGSRC + +! set novegtype based on vegetation classification + if(ivegsrc==2)then + novegtype=13 + else if(ivegsrc==1)then + novegtype=20 + else if(ivegsrc==0)then + novegtype=24 + end if + print*,'novegtype= ',novegtype + + VarName='CU_PHYSICS' + if(me == 0)then + call nemsio_getheadvar(nfile,trim(VarName),iCU_PHYSICS,iret) + if (iret /= 0) then + print*,VarName," not found in file-Assigned 4 for SAS as default" + iCU_PHYSICS=4 + end if + end if + call mpi_bcast(iCU_PHYSICS,1,MPI_INTEGER,0,mpi_comm_comp,iret) + if (me == 0) print*,'CU_PHYSICS= ',iCU_PHYSICS +! waiting to retrieve lat lon infor from raw GFS output +! VarName='DX' + +! VarName='DY' + +! GFS does not need DT to compute accumulated fields, set it to one +! VarName='DT' + DT=1 +! GFS does not need truelat +! VarName='TRUELAT1' + +! VarName='TRUELAT2' + +! Specigy maptype=4 for Gaussian grid +! maptype=4 +! write(6,*) 'maptype is ', maptype +! HBM2 is most likely not in Grib message, set them to ones + HBM2=1.0 + +! try to get kgds from flux grib file and then convert to igds that is used by GRIBIT.f +! flux files are now nemsio files so comment the following lines out +! if(me == 0)then +! jpds=-1.0 +! jgds=-1.0 +! igds=0 +! call getgb(iunit,0,im_jm,0,jpds,jgds,kf & +! ,k,kpds,kgds,lb,dummy,ierr) +! if(ierr == 0)then +! call R63W72(KPDS,KGDS,JPDS,IGDS(1:18)) +! print*,'in INITPOST_GFS,IGDS for GFS= ',(IGDS(I),I=1,18) +! end if +! end if +! call mpi_bcast(igds(1),18,MPI_INTEGER,0,mpi_comm_comp,iret) +! print*,'IGDS for GFS= ',(IGDS(I),I=1,18) + +! Specigy grid type +! if(iostatusFlux==0)then + if(IGDS(4)/=0)then + maptype=IGDS(3) + else if((im/2+1)==jm)then + maptype=0 !latlon grid + else + maptype=4 ! default gaussian grid + end if + gridtype='A' + + if (me == 0) write(6,*) 'maptype and gridtype is ', maptype,gridtype + +! start retrieving data using gfsio, first land/sea mask + +! VarName='land' +! VcoordName='sfc' +! l=1 + +! if(me == 0)then +! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) +! + ,l,dummy,iret=iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! dummy=spval +! else +! +! do j = 1, jm +! do i = 1, im +! dummy(I,J)=1.0 - dummy(I,J) ! convert Grib message to 2D +! if (j == jm/2 .and. mod(i,10) == 0) +! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j) +! +! enddo +! enddo +! end if +! end if +! +! call mpi_scatterv(dummy,icnt,idsp,mpi_real +! + ,sm(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) +! if (iret /= 0)print*,'Error scattering array';stop + + VcoordName='sfc' ! surface fileds + l=1 + +! start retrieving data using getgb, first land/sea mask + VarName='land' + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,impf,jmpf,nframe,sm) + +! where(sm /= spval)sm=1.0-sm ! convert to sea mask +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j) + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',sm(isa,jsa) + + +! sea ice mask using getgb + + VarName='icec' + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,sice) + +! if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa) + +! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea mask=0 +! GFS flux files have land points with non-zero sea ice, per Iredell, these +! points have sea ice changed to zero, i.e., trust land mask more than sea ice +! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0 + enddo + enddo + +! Terrain height * G using nemsio + VarName='hgt' + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,fis) + +! where(fis /= spval)fis=fis*grav + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (fis(i,j) /= spval) then + zint(i,j,lp1) = fis(i,j) + fis(i,j) = fis(i,j) * grav + + endif + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',fis(isa,jsa) + +! Surface pressure using nemsio + VarName='pres' + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,pint(1,jsta_2l,lp1)) + +! if(debugprint)print*,'sample surface pressure = ',pint(isa,jsa,lp1 + +! +! vertical loop for Layer 3d fields +! -------------------------------- + VcoordName = 'mid layer' + + do l=1,lm + ll=lm-l+1 + +! model level T + print*,'start retrieving GFS T using nemsio' + VarName='tmp' + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,t(1,jsta_2l,ll)) + +! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,t(isa,jsa,ll) + +! model level q + VarName='spfh' + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,q(1,jsta_2l,ll)) +! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,q(isa,jsa,ll) + +! i model level u + VarName='ugrd' + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,uh(1,jsta_2l,ll)) +! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,uh(isa,jsa,ll) + +! model level v + VarName='vgrd' + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,vh(1,jsta_2l,ll)) +! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,vh(isa,jsa,ll) + +! model level pressure + if (.not. hyb_sigp) then + VarName='pres' + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,pmid(1,jsta_2l,ll)) +! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,pmid(isa,jsa,ll) + +! GFS is on A grid and does not need PMIDV + +! dp + VarName='dpres' +! write(0,*)' bef getnemsandscatter ll=',ll,' l=',l,VarName + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,dpres(1,jsta_2l,ll)) +! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,pmid(isa,jsa,ll) + endif +! ozone mixing ratio + VarName='o3mr' + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,o3(1,jsta_2l,ll)) + +! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,o3(isa,jsa,ll) +! write(1000+me,*)'sample ',ll,VarName,' = ',ll,o3(isa,jsa,ll) + +! cloud water and ice mixing ratio for zhao scheme +! need to look up old eta post to derive cloud water/ice from cwm +! Zhao scheme does not produce suspended rain and snow + +!$omp parallel do private(i,j) + do j = jsta, jend + do i=1,im + qqw(i,j,ll) = 0. + qqr(i,j,ll) = 0. + qqs(i,j,ll) = 0. + qqi(i,j,ll) = 0. + enddo + enddo + + VarName='clwmr' + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,cwm(1,jsta_2l,ll)) +! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,cwm(isa,jsa,ll) + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if(t(i,j,ll) < (TFRZ-15.) )then ! dividing cloud water from ice + qqi(i,j,ll) = cwm(i,j,ll) + else + qqw(i,j,ll) = cwm(i,j,ll) + end if +! if (j == jm/2 .and. mod(i,50) == 0) +! + print*,'sample ',trim(VarName), ' after scatter= ' +! + ,i,j,ll,cwm(i,j,ll) + end do + end do +! if (iret /= 0)print*,'Error scattering array';stop + +! pressure vertical velocity + VarName='vvel' + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,omga(1,jsta_2l,ll)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,omga(isa,jsa,ll) + +! With SHOC NEMS/GSM does output TKE now + VarName='tke' + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,q2(1,jsta_2l,ll)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,q2(isa,jsa,ll) + + + end do ! do loop for l + +! construct interface pressure from model top (which is zero) and dp from top down PDTOP +! pdtop = spval + pt = 0. +! pd = spval ! GFS does not output PD + + ii = im/2 + jj = (jsta+jend)/2 + +!!!!! COMPUTE Z, GFS integrates Z on mid-layer instead +!!! use GFS contants to see if height becomes more aggreable to GFS pressure grib file + if (hyb_sigp) then + do l=lm,1,-1 +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + pint(i,j,l) = ak5(lm+2-l) + bk5(lm+2-l)*pint(i,j,lp1) + pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) ! for now - Moorthi + enddo + enddo + if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l) + enddo + else + do l=2,lm +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) + enddo + enddo + if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l) + end do + endif + + allocate(wrk1(im,jsta:jend),wrk2(im,jsta:jend)) + allocate(fi(im,jsta:jend,2)) + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + pd(i,j) = spval ! GFS does not output PD + pint(i,j,1) = PT + alpint(i,j,lp1) = log(pint(i,j,lp1)) + wrk1(i,j) = log(PMID(I,J,LM)) + wrk2(i,j) = T(I,J,LM)*(Q(I,J,LM)*fv+1.0) + FI(I,J,1) = FIS(I,J) & + + wrk2(i,j)*rgas*(ALPINT(I,J,Lp1)-wrk1(i,j)) + ZMID(I,J,LM) = FI(I,J,1) * gravi + end do + end do + + print *,' Tprof=',t(ii,jj,:) + print *,' Qprof=',q(ii,jj,:) + +! SECOND, INTEGRATE HEIGHT HYDROSTATICLY, GFS integrate height on mid-layer + + DO L=LM,2,-1 ! omit computing model top height because it's infinity + ll = l - 1 +! write(0,*)' me=',me,'ll=',ll,' gravi=',gravi,rgas,' fv=',fv +!$omp parallel do private(i,j,tvll,pmll,fact) + do j = jsta, jend +! write(0,*)' j=',j,' me=',me + do i = 1, im + alpint(i,j,l) = log(pint(i,j,l)) + tvll = T(I,J,LL)*(Q(I,J,LL)*fv+1.0) + pmll = log(PMID(I,J,LL)) + +! if (me == 0 .and. i == ii .and. j == jj ) print*,'L ZINT= ',l,' tvll =', tvll, & +! ' pmll=',pmll,' wrk2=',wrk2(i,j),' wrk1=',wrk1(i,j),' fi1=',fi(i,j,1), & +! ' T=',T(i,j,LL),' Q=',Q(i,j,ll) + + FI(I,J,2) = FI(I,J,1) + (0.5*rgas)*(wrk2(i,j)+tvll) & + * (wrk1(i,j)-pmll) + ZMID(I,J,LL) = FI(I,J,2) * gravi +! + FACT = (ALPINT(I,J,L)-wrk1(i,j)) / (pmll-wrk1(i,j)) + ZINT(I,J,L) = ZMID(I,J,L) + (ZMID(I,J,LL)-ZMID(I,J,L)) * FACT + FI(I,J,1) = FI(I,J,2) + wrk1(i,J) = pmll + wrk2(i,j) = tvll +! if (me == 0 .and. i == ii .and. j == jj ) print*,'L ZINT= ',l,zint(ii,jj,l), & +! 'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)),'pmid(l-1)=', & +! LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L),'zmid(l-1)=',ZMID(Ii,Jj,L-1) + ENDDO + ENDDO + + if (me == 0) print*,'L ZINT= ',l,zint(ii,jj,l), & + 'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)),'pmid(l-1)=', & + LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L),'zmid(l-1)=',ZMID(Ii,Jj,L-1) + ENDDO + deallocate(wrk1,wrk2,fi) + + + if (gocart_on) then + +! GFS output dust in nemsio (GOCART) + do n=1,nbin_du + do l=1,lm +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + dust(i,j,l,n) = spval + enddo + enddo + enddo + enddo +! DUST = SPVAL + VarName='du001' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,dust(1,jsta_2l,ll,1)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,1) + end do ! do loop for l + + VarName='du002' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,dust(1,jsta_2l,ll,2)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,2) + end do ! do loop for l + + VarName='du003' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,dust(1,jsta_2l,ll,3)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,3) + end do ! do loop for l + + VarName='du004' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,dust(1,jsta_2l,ll,4)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,4) + end do ! do loop for l + + VarName='du005' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,dust(1,jsta_2l,ll,5)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,5) + end do ! do loop for l +! +! GFS output sea salt in nemsio (GOCART) + do n=1,nbin_ss + do l=1,lm +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + salt(i,j,l,n) = spval + enddo + enddo + enddo + enddo +! SALT = SPVAL + VarName='ss001' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,salt(1,jsta_2l,ll,1)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,1) + end do ! do loop for l + + VarName='ss002' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,salt(1,jsta_2l,ll,2)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,2) + end do ! do loop for l + + VarName='ss003' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,salt(1,jsta_2l,ll,3)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,3) + end do ! do loop for l + + VarName='ss004' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,salt(1,jsta_2l,ll,4)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,4) + end do ! do loop for l + + VarName='ss005' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,salt(1,jsta_2l,ll,5)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,5) + end do ! do loop for l + +! GFS output black carbon in nemsio (GOCART) + do n=1,nbin_oc + do l=1,lm +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + soot(i,j,l,n) = spval + enddo + enddo + enddo + enddo +! SOOT = SPVAL + VarName='bcphobic' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,soot(1,jsta_2l,ll,1)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,soot(isa,jsa,ll,1) + end do ! do loop for l + + VarName='bcphilic' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,soot(1,jsta_2l,ll,2)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,soot(isa,jsa,ll,2) + end do ! do loop for l + +! GFS output organic carbon in nemsio (GOCART) + do n=1,nbin_oc + do l=1,lm +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + waso(i,j,l,n) = spval + enddo + enddo + enddo + enddo +! WASO = SPVAL + VarName='ocphobic' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,waso(1,jsta_2l,ll,1)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,waso(isa,jsa,ll,1) + end do ! do loop for l + + VarName='ocphilic' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,waso(1,jsta_2l,ll,2)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,waso(isa,jsa,ll,2) + end do ! do loop for l + +! GFS output sulfate in nemsio (GOCART) + do n=1,nbin_su + do l=1,lm +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + suso(i,j,l,n) = spval + enddo + enddo + enddo + enddo +! SUSO = SPVAL + VarName='so4' + VcoordName='mid layer' + do l=1,lm + ll=lm-l+1 + call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,suso(1,jsta_2l,ll,1)) +! if(debugprint)print*,'sample l ',VarName,' = ',ll,suso(isa,jsa,ll,1) + end do ! do loop for l + + +! -- compute air density RHOMID and remove negative tracer values + do l=1,lm +!$omp parallel do private(i,j,n,tv) + do j=jsta,jend + do i=1,im + + TV = T(I,J,L) * (H1+D608*MAX(Q(I,J,L),QMIN)) + RHOMID(I,J,L) = PMID(I,J,L) / (RD*TV) + do n = 1, NBIN_DU + IF ( dust(i,j,l,n) < SPVAL) THEN + DUST(i,j,l,n) = MAX(DUST(i,j,l,n), 0.0) + ENDIF + enddo + do n = 1, NBIN_SS + IF ( salt(i,j,l,n) < SPVAL) THEN + SALT(i,j,l,n) = MAX(SALT(i,j,l,n), 0.0) + ENDIF + enddo + do n = 1, NBIN_OC + IF ( waso(i,j,l,n) < SPVAL) THEN + WASO(i,j,l,n) = MAX(WASO(i,j,l,n), 0.0) + ENDIF + enddo + do n = 1, NBIN_BC + IF ( soot(i,j,l,n) < SPVAL) THEN + SOOT(i,j,l,n) = MAX(SOOT(i,j,l,n), 0.0) + ENDIF + enddo + do n = 1, NBIN_SU + IF ( suso(i,j,l,n) < SPVAL) THEN + SUSO(i,j,l,n) = MAX(SUSO(i,j,l,n), 0.0) + ENDIF + enddo + + end do + end do + end do + endif ! endif for gocart_on +! + +! PBL height using nemsio + VarName='hpbl' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,pblh) +! if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa) + +! frictional velocity using nemsio + VarName='fricv' +! VcoordName='sfc' +! l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,ustar) +! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa) + +! roughness length using getgb + VarName='sfcr' +! VcoordName='sfc' +! l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,z0) +! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa) + +! surface potential T using getgb + VarName='tmp' +! VcoordName='sfc' +! l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,ths) + +! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (ths(i,j) /= spval) then +! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) + ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa + endif + QS(i,j) = SPVAL ! GFS does not have surface specific humidity + twbs(i,j) = SPVAL ! GFS does not have inst sensible heat flux + qwbs(i,j) = SPVAL ! GFS does not have inst latent heat flux + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa) + + +! GFS does not have time step and physics time step, make up ones since they +! are not really used anyway + NPHS=2. + DT=80. + DTQ2 = DT * NPHS !MEB need to get physics DT + TSPH = 3600./DT !MEB need to get DT +! All GFS time-averaged quantities are in 6 hour bucket +! TPREC=6.0 + +! convective precip in m per physics time step using gfsio +! VarName='cprat' +! VcoordName='sfc' +! l=1 +! if(me == 0)then +! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & +! + ,l,dummy,iret=iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! dummy=spval +! else +! do j = 1, jm +! do i = 1, im +! dummy(I,J)= dummy(i,j)*dtq2/1000. ! convert to m +! if (j == jm/2 .and. mod(i,50) == 0) +! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j) +! enddo +! enddo +! end if +! end if +! call mpi_scatterv(dummy,icnt,idsp,mpi_real & +! + , avgcprate(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) +! if (iret /= 0)print*,'Error scattering array';stop + +! convective precip in m per physics time step using getgb + VarName='cprat' +! VcoordName='sfc' +! l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,avgcprate) +! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001) + cprate(i,j) = avgcprate(i,j) + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa) + +! print*,'maxval CPRATE: ', maxval(CPRATE) + +! precip rate in m per physics time step using getgb + VarName='prate' +! VcoordName='sfc' +! l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,avgprec) +! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgprec(i,j) /= spval) avgprec(i,j) = avgprec(i,j) * (dtq2*0.001) + enddo + enddo + +! if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa) + + prec=avgprec !set avg cprate to inst one to derive other fields + +! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f + + +! inst snow water eqivalent using nemsio + VarName='weasd' +! VcoordName='sfc' +! l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,sno) +! if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa) + +! snow depth in mm using nemsio + VarName='snod' +! VcoordName='sfc' +! l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,si) +! where(si /= spval)si=si*1000. ! convert to mm +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 + CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency + lspa(i,j) = spval ! GFS does not have similated precip + TH10(i,j) = SPVAL ! GFS does not have 10 m theta + TH10(i,j) = SPVAL ! GFS does not have 10 m theta + Q10(i,j) = SPVAL ! GFS does not have 10 m humidity + ALBASE(i,j) = SPVAL ! GFS does not have snow free albedo + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa) + +!!$omp parallel do private(i,j,l) +! do l=1,lm +! do j=jsta,jend +! do i=1,im +! Q2(i,j,l) = SPVAL ! GFS does not have TKE because it uses MRF scheme +! ! GFS does not have surface exchange coeff +! enddo +! enddo +! enddo + +! 2m T using nemsio + VarName='tmp' + VcoordName='2 m above gnd' +! l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,tshltr) +! if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) + +! GFS does not have 2m pres, estimate it, also convert t to theta + Do j=jsta,jend + Do i=1,im + PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) + tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta +! if (j == jm/2 .and. mod(i,50) == 0) +! + print*,'sample 2m T and P after scatter= ' +! + ,i,j,tshltr(i,j),pshltr(i,j) + end do + end do + +! 2m specific humidity using gfsio +! VarName='spfh' +! VcoordName='2m above gnc' +! l=1 +! if(me == 0)then +! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & +! + ,l,dummy,iret=iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! dummy=spval +! end if +! end if +! call mpi_scatterv(dummy,icnt,idsp,mpi_real & +! + ,qshltr(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) +! if (iret /= 0)print*,'Error scattering array';stop + +! 2m specific humidity using nemsio + VarName='spfh' + VcoordName='2 m above gnd' +! l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,qshltr) +! if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa) + + +! mid day avg albedo in fraction using gfsio +! VarName='albdo' +! VcoordName='sfc' +! l=1 +! if(me == 0)then +! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & +! + ,l,dummy,iret=iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! dummy=spval +! else +! do j = 1, jm +! do i = 1, im +! dummy(I,J)= dummy(i,j)/100. ! convert to fraction +! if (j == jm/2 .and. mod(i,50) == 0) +! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j) +! enddo +! enddo +! end if +! end if +! call mpi_scatterv(dummy,icnt,idsp,mpi_real & +! + ,avgalbedo(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) +! if (iret /= 0)print*,'Error scattering array';stop + +! mid day avg albedo in fraction using nemsio + VarName='albdo' + VcoordName='sfc' +! l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,avgalbedo) +! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) + +! time averaged column cloud fractionusing nemsio + VarName='tcdc' + VcoordName='atmos col' +! l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,avgtcdc) +! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01 + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa) + +! GFS probably does not use zenith angle +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + Czen(i,j) = spval + CZMEAN(i,j) = SPVAL + enddo + enddo + +! maximum snow albedo in fraction using nemsio + VarName='mxsalb' + VcoordName='sfc' +! l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,mxsnal) +! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01 + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa) + +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + radot(i,j) = spval ! GFS does not have inst surface outgoing longwave + enddo + enddo + +! GFS probably does not use sigt4, set it to sig*t^4 +!$omp parallel do private(i,j,tlmh) + Do j=jsta,jend + Do i=1,im + TLMH = T(I,J,LM) * T(I,J,LM) + Sigt4(i,j) = 5.67E-8 * TLMH * TLMH + End do + End do + +! TG is not used, skip it for now + +! will retrive f_ice when GFS switches to Ferrier scheme +! varname='F_ICE' +! call retrieve_index(index,VarName,varname_all,nrecs,iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! F_ice=SPVAL +! else +! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm +! this_length=im*(jend_2u-jsta_2l+1)*lm +! call mpi_file_read_at(iunit,this_offset +! + ,buf3d,this_length,mpi_real4 +! + , mpi_status_ignore, ierr) +! if (ierr /= 0) then +! print*,"Error reading ", VarName,"Assigned missing values" +! F_ice=SPVAL +! else +! do l = 1, lm +! ll=lm-l+1 +! do j = jsta_2l, jend_2u +! do i = 1, im +! F_ice( i, j, l ) = buf3d ( i, ll, j ) +! if(i == im/2.and.j == (jsta+jend)/2)print*,'sample F_ice= ', +! + i,j,l,F_ice( i, j, l ) +! end do +! end do +! end do +! end if +! end if + +! varname='F_RAIN' +! call retrieve_index(index,VarName,varname_all,nrecs,iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! F_rain=SPVAL +! else +! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm +! this_length=im*(jend_2u-jsta_2l+1)*lm +! call mpi_file_read_at(iunit,this_offset +! + ,buf3d,this_length,mpi_real4 +! + , mpi_status_ignore, ierr) +! if (ierr /= 0) then +! print*,"Error reading ", VarName,"Assigned missing values" +! F_rain=SPVAL +! else +! do l = 1, lm +! ll=lm-l+1 +! do j = jsta_2l, jend_2u +! do i = 1, im +! F_rain( i, j, l ) = buf3d ( i, ll, j ) +! if(i == im/2.and.j == (jsta+jend)/2)print*,'sample F_rain= ', +! + i,j,l,F_rain( i, j, l ) +! end do +! end do +! end do +! end if +! end if + +! varname='F_RIMEF' +! call retrieve_index(index,VarName,varname_all,nrecs,iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! F_RimeF=SPVAL +! else +! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm +! this_length=im*(jend_2u-jsta_2l+1)*lm +! call mpi_file_read_at(iunit,this_offset +! + ,buf3d,this_length,mpi_real4 +! + , mpi_status_ignore, ierr) +! if (ierr /= 0) then +! print*,"Error reading ", VarName,"Assigned missing values" +! F_RimeF=SPVAL +! else +! do l = 1, lm +! ll=lm-l+1 +! do j = jsta_2l, jend_2u +! do i = 1, im +! F_RimeF( i, j, l ) = buf3d ( i, ll, j ) +! if(i == im/2.and.j == (jsta+jend)/2)print*, +! + 'sample F_RimeF= ',i,j,l,F_RimeF( i, j, l ) +! end do +! end do +! end do +! end if +! end if + +! GFS does not have model level cloud fraction -> derive cloud fraction +! CFR=SPVAL +! allocate(qstl(lm)) +! print*,'start deriving cloud fraction' + +! do j=jsta,jend +! do i=1,im +! do l=1,lm +! if(i==im/2.and.j==jsta)print*,'sample T=',t(i,j,l) +! es=fpvsnew(t(i,j,l)) +! if(i==im/2.and.j==jsta)print*,'sample ES=',es +! es=min(es,pmid(i,j,l)) +! if(i==im/2.and.j==jsta)print*,'sample ES=',es +! qstl(l)=con_eps*es/(pmid(i,j,l)+con_epsm1*es) !saturation q for GFS +! end do +! call progcld1 +!................................... + +! --- inputs: +! & ( pmid(i,j,1:lm)/100.,pint(i,j,1:lm+1)/100., +! & t(i,j,1:lm),q(i,j,1:lm),qstl,cwm(i,j,1:lm), +! & gdlat(i,j),gdlon(i,j), +! & 1, lm, lm+1, 0, +! --- outputs: +! & cfr(i,j,1:lm) +! & ) +! do l=1,lm +! cfr(i,j,l)=cldtot(l) +! end do +! end do +! end do + allocate(p2d(im,lm),t2d(im,lm),q2d(im,lm),cw2d(im,lm), & + qs2d(im,lm),cfr2d(im,lm)) + do j=jsta,jend +!$omp parallel do private(i,k,es) + do k=1,lm + do i=1,im + p2d(i,k) = pmid(i,j,k)*0.01 + t2d(i,k) = t(i,j,k) + q2d(i,k) = q(i,j,k) + cw2d(i,k) = cwm(i,j,k) + es = min(fpvsnew(t(i,j,k)),pmid(i,j,k)) + qs2d(i,k) = eps*es/(pmid(i,j,k)+epsm1*es)!saturation q for GFS + enddo + enddo + call progcld1 & +!................................... +! --- inputs: + ( p2d,t2d,q2d,qs2d,cw2d,im,lm,0, & +! --- outputs: + cfr2d & + ) +!$omp parallel do private(i,k) + do k=1,lm + do i=1,im + cfr(i,j,k) = cfr2d(i,k) + enddo + end do + end do + deallocate(p2d,t2d,q2d,qs2d,cw2d,cfr2d) + + +! ask murthy if there is snow rate in GFS +! varname='SR' +! call retrieve_index(index,VarName,varname_all,nrecs,iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! SR=SPVAL +! else +! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im +! this_length=im*(jend_2u-jsta_2l+1) +! call mpi_file_read_at(iunit,this_offset +! + ,sr,this_length,mpi_real4 +! + , mpi_status_ignore, ierr) +! if (ierr /= 0) then +! print*,"Error reading ", VarName,"Assigned missing values" +! SR=SPVAL +! end if +! end if + +! GFS does not have inst cloud fraction for high, middle, and low cloud +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + cfrach(i,j) = spval + cfracl(i,j) = spval + cfracm(i,j) = spval + enddo + enddo + +! ave high cloud fraction using nemsio + VarName='tcdc' + VcoordName='high cld lay' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,avgcfrach) +! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01 + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa) + +! ave low cloud fraction using nemsio + VarName='tcdc' + VcoordName='low cld lay' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,avgcfracl) +! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01 + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa) + +! ave middle cloud fraction using nemsio + VarName='tcdc' + VcoordName='mid cld lay' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,avgcfracm) +! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01 + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa) + +! inst convective cloud fraction using nemsio + VarName='tcdc' + VcoordName='convect-cld laye' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,cnvcfr) +! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01 + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa) + +! slope type using nemsio + VarName='sltyp' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,buf) +! where(buf /= spval)islope=nint(buf) +!$omp parallel do private(i,j) + do j = jsta_2l, jend_2u + do i=1,im + if (buf(i,j) < spval) then + islope(i,j) = nint(buf(i,j)) + else + islope(i,j) = 0 + endif + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa) + +! plant canopy sfc wtr in m using nemsio + VarName='cnwat' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,cmc) +! where(cmc /= spval)cmc=cmc/1000. ! convert from kg*m^2 to m +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001 + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa) + +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + grnflx(i,j) = spval ! GFS does not have inst ground heat flux + enddo + enddo + +! GFS does not have snow cover yet +! VarName='gflux' +! VcoordName='sfc' +! l=1 +! if(me == 0)then +! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & +! + ,l,dummy,iret=iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! dummy=spval +! end if +! end if +! call mpi_scatterv(dummy,icnt,idsp,mpi_real & +! + , pctsno(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) +! if (iret /= 0)print*,'Error scattering array';stop + +! asuume tg3 in GFS is the same as soiltb in wrf nmm. It's in sfc file, will +! be able to read it when it merges to gfs io +! soiltb is not being put out, comment it out +! VarName='tg3' +! VcoordName='sfc' +! l=1 +! if(me == 0)then +! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & +! ,l,dummy,iret=iret) +! if (iret /= 0) then +! print*,VarName," not found in file-Assigned missing values" +! dummy=spval +! end if +! end if +! call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & +! , soiltb(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) +! if (iret /= 0)print*,'Error scattering array';stop + +! vegetation fraction in fraction. using nemsio + VarName='veg' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,vegfrc) +! where(vegfrc /= spval) +! vegfrc=vegfrc/100. ! convert to fraction +! elsewhere (vegfrc == spval) +! vegfrc=0. ! set to zero to be reasonable input for crtm +! end where +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (vegfrc(i,j) /= spval) then + vegfrc(i,j) = vegfrc(i,j) * 0.01 + else + vegfrc(i,j) = 0.0 + endif + enddo + enddo +! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa) + +! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam + + SLDPTH(1) = 0.10 + SLDPTH(2) = 0.3 + SLDPTH(3) = 0.6 + SLDPTH(4) = 1.0 + +! liquid volumetric soil mpisture in fraction using nemsio + VarName='soill' + VcoordName='0-10 cm down' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,sh2o(1,jsta_2l,1)) +! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1) + + VarName='soill' + VcoordName='10-40 cm down' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,sh2o(1,jsta_2l,2)) +! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2) + + VarName='soill' + VcoordName='40-100 cm down' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,sh2o(1,jsta_2l,3)) +! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3) + + VarName='soill' + VcoordName='100-200 cm down' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,sh2o(1,jsta_2l,4)) +! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4) + +! volumetric soil moisture using nemsio + VarName='soilw' + VcoordName='0-10 cm down' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,smc(1,jsta_2l,1)) +! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1) + + VarName='soilw' + VcoordName='10-40 cm down' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,smc(1,jsta_2l,2)) +! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2) + + VarName='soilw' + VcoordName='40-100 cm down' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,smc(1,jsta_2l,3)) +! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3) + + VarName='soilw' + VcoordName='100-200 cm down' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,smc(1,jsta_2l,4)) +! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4) + +! soil temperature using nemsio + VarName='tmp' + VcoordName='0-10 cm down' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,stc(1,jsta_2l,1)) +! if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1) + + VarName='tmp' + VcoordName='10-40 cm down' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,stc(1,jsta_2l,2)) +! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2) + + VarName='tmp' + VcoordName='40-100 cm down' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,stc(1,jsta_2l,3)) +! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3) + + VarName='tmp' + VcoordName='100-200 cm down' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,stc(1,jsta_2l,4)) +! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4) + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 + ncfrcv(i,j) = 1.0 + acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 + ncfrst(i,j) = 1.0 + ssroff(i,j) = spval ! GFS does not have storm runoff + bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF + rlwin(i,j) = spval ! GFS does not have inst incoming sfc longwave + rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave + enddo + enddo +! trdlw(i,j) = 6.0 + ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1 + +! time averaged incoming sfc longwave using nemsio + VarName='dlwrf' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,alwin) + +! time averaged outgoing sfc longwave using gfsio + VarName='ulwrf' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,alwout) +! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j) + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa) + +! time averaged outgoing model top longwave using gfsio + VarName='ulwrf' + VcoordName='nom. top' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,alwtoa) +! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa) + +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + rswin(i,j) = spval ! GFS does not have inst incoming sfc shortwave + rswinc(i,j) = spval ! GFS does not have inst incoming clear sky sfc shortwave + rswout(i,j) = spval ! GFS does not have inst outgoing sfc shortwave + enddo + enddo + +! GFS incoming sfc longwave has been averaged, set ARDLW to 1 + ardsw=1.0 +! trdsw=6.0 + +! time averaged incoming sfc shortwave using gfsio + VarName='dswrf' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,aswin) +! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa) + +! time averaged incoming sfc uv-b using getgb + VarName='duvb' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,auvbin) +! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa) + +! time averaged incoming sfc clear sky uv-b using getgb + VarName='cduvb' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,auvbinc) +! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa) + +! time averaged outgoing sfc shortwave using gfsio + VarName='uswrf' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,aswout) +! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j) + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa) + +! time averaged model top incoming shortwave + VarName='dswrf' + VcoordName='nom. top' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,aswintoa) + +! time averaged model top outgoing shortwave + VarName='uswrf' + VcoordName='nom. top' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,aswtoa) +! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa) + +! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux +! has reversed sign convention using gfsio + VarName='shtfl' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,sfcshx) +! where (sfcshx /= spval)sfcshx=-sfcshx +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j) + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa) + +! GFS surface flux has been averaged, set ASRFC to 1 + asrfc=1.0 +! tsrfc=6.0 + +! time averaged surface latent heat flux, multiplied by -1 because wrf model flux +! has reversed sign vonvention using gfsio + VarName='lhtfl' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,sfclhx) +! where (sfclhx /= spval)sfclhx=-sfclhx +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j) + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa) + +! time averaged ground heat flux using nemsio + VarName='gflux' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,subshx) +! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa) + +! time averaged zonal momentum flux using gfsio + VarName='uflx' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,sfcux) +! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa) + +! time averaged meridional momentum flux using nemsio + VarName='vflx' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,sfcvx) +! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa) + +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + snopcx(i,j) =spval ! GFS does not have snow phase change heat flux + sfcuvx(i,j) = spval ! GFS does not use total momentum flux + enddo + enddo + +! time averaged zonal gravity wave stress using nemsio + VarName='u-gwd' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,gtaux) +! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa) + +! time averaged meridional gravity wave stress using getgb + VarName='v-gwd' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,gtauy) +! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa) + +! time averaged accumulated potential evaporation + VarName='pevpr' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,potevp) +! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa) + + do l=1,lm +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im +! GFS does not have temperature tendency due to long wave radiation + rlwtt(i,j,l) = spval +! GFS does not have temperature tendency due to short wave radiation + rswtt(i,j,l) = spval +! GFS does not have temperature tendency due to latent heating from convection + tcucn(i,j,l) = spval + tcucns(i,j,l) = spval +! GFS does not have temperature tendency due to latent heating from grid scale + train(i,j,l) = spval + enddo + enddo + enddo + +! set avrain to 1 + avrain=1.0 + avcnvc=1.0 + theat=6.0 ! just in case GFS decides to output T tendency + +! 10 m u using nemsio + VarName='ugrd' + VcoordName='10 m above gnd' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,u10) +! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa) + do j=jsta,jend + do i=1,im + u10h(i,j)=u10(i,j) + end do + end do + +! 10 m v using gfsio + VarName='vgrd' + VcoordName='10 m above gnd' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,v10) + do j=jsta,jend + do i=1,im + v10h(i,j)=v10(i,j) + end do + end do +! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa) + +! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon + VarName='vgtyp' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,buf) +! where (buf /= spval) +! ivgtyp=nint(buf) +! elsewhere +! ivgtyp=0 !need to feed reasonable value to crtm +! end where +!$omp parallel do private(i,j) + do j = jsta_2l, jend_2u + do i=1,im + if (buf(i,j) < spval) then + ivgtyp(i,j) = nint(buf(i,j)) + else + ivgtyp(i,j) = 0 + endif + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa) + +! soil type, it's in GFS surface file, hopefully will merge into gfsio soon + VarName='sotyp' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,buf) +! where (buf /= spval) +! isltyp=nint(buf) +! elsewhere +! isltyp=0 !need to feed reasonable value to crtm +! end where +!$omp parallel do private(i,j) + do j = jsta_2l, jend_2u + do i=1,im + if (buf(i,j) < spval) then + isltyp(i,j) = nint(buf(i,j)) + else + isltyp(i,j) = 0 + endif + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa) + +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + smstav(i,j) = spval ! GFS does not have soil moisture availability + smstot(i,j) = spval ! GFS does not have total soil moisture + sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation + sfcexc(i,j) = spval ! GFS does not have surface exchange coefficient + acsnow(i,j) = spval ! GFS does not have averaged accumulated snow + acsnom(i,j) = spval ! GFS does not have snow melt + sst(i,j) = spval ! GFS does not have sst???? + thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute + qz0(i,j) = spval ! GFS does not output humidity at roughness length + uz0(i,j) = spval ! GFS does not output u at roughness length + vz0(i,j) = spval ! GFS does not output humidity at roughness length + enddo + enddo + do l=1,lm +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + EL_PBL(i,j,l) = spval ! GFS does not have mixing length + exch_h(i,j,l) = spval ! GFS does not output exchange coefficient + enddo + enddo + enddo +! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa) + +! retrieve inst convective cloud top, GFS has cloud top pressure instead of index, +! will need to modify CLDRAD.f to use pressure directly instead of index + VarName='pres' + VcoordName='convect-cld top' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,ptop) +! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa) + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + htop(i,j) = spval + if(ptop(i,j) <= 0.0) ptop(i,j) = spval + enddo + enddo + do j=jsta,jend + do i=1,im + if(ptop(i,j) < spval)then + do l=1,lm + if(ptop(i,j) <= pmid(i,j,l))then + htop(i,j) = l +! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', & +! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j) + exit + end if + end do + end if + end do + end do + +! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, +! will need to modify CLDRAD.f to use pressure directly instead of index + VarName='pres' + VcoordName='convect-cld bot' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,pbot) +! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa) + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + hbot(i,j) = spval + if(pbot(i,j) <= 0.0) pbot(i,j) = spval + enddo + enddo + do j=jsta,jend + do i=1,im +! if(.not.lb(i,j))print*,'false bitmask for pbot at ' +! + ,i,j,pbot(i,j) + if(pbot(i,j) < spval)then + do l=lm,1,-1 + if(pbot(i,j) >= pmid(i,j,l)) then + hbot(i,j) = l +! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', & +! pbot(i,j),pmid(i,j,l),hbot(i,j) + exit + end if + end do + end if + end do + end do + +! retrieve time averaged low cloud top pressure using nemsio + VarName='pres' + VcoordName='low cld top' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,ptopl) +! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa) + +! retrieve time averaged low cloud bottom pressure using nemsio + VarName='pres' + VcoordName='low cld bot' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,pbotl) +! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa) + +! retrieve time averaged low cloud top temperature using nemsio + VarName='tmp' + VcoordName='low cld top' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,Ttopl) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa) + +! retrieve time averaged middle cloud top pressure using nemsio + VarName='pres' + VcoordName='mid cld top' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,ptopm) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa) + +! retrieve time averaged middle cloud bottom pressure using nemsio + VarName='pres' + VcoordName='mid cld bot' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,pbotm) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa) + +! retrieve time averaged middle cloud top temperature using nemsio + VarName='tmp' + VcoordName='mid cld top' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,Ttopm) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa) + +! retrieve time averaged high cloud top pressure using nemsio ********* + VarName='pres' + VcoordName='high cld top' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,ptoph) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa) + +! retrieve time averaged high cloud bottom pressure using nemsio + VarName='pres' + VcoordName='high cld bot' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,pboth) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa) + +! retrieve time averaged high cloud top temperature using nemsio + VarName='tmp' + VcoordName='high cld top' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,Ttoph) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa) + +! retrieve boundary layer cloud cover using nemsio + VarName='tcdc' + VcoordName='bndary-layer cld' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,pblcfr) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa) +! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction +!$omp parallel do private(i,j) + do j = jsta_2l, jend_2u + do i=1,im + if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01 + enddo + enddo + +! retrieve cloud work function using nemsio + VarName='cwork' + VcoordName='atmos col' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,cldwork) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa) + +! retrieve water runoff using nemsio + VarName='watr' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,runoff) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa) + +! retrieve shelter max temperature using nemsio + VarName='tmax' + VcoordName='2 m above gnd' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,maxtshltr) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,maxtshltr(isa,jsa) + +! retrieve shelter max temperature using nemsio + VarName='tmin' + VcoordName='2 m above gnd' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,mintshltr) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & +! 1,mintshltr(im/2,(jsta+jend)/2) + +!$omp parallel do private(i,j) + do j=jsta_2l,jend_2u + do i=1,im + MAXRHSHLTR(i,j) = SPVAL + MINRHSHLTR(i,j) = SPVAL + enddo + enddo + +! retrieve ice thickness using nemsio + VarName='icetk' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,dzice) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa) + +! retrieve wilting point using nemsio + VarName='wilt' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,smcwlt) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa) + +! retrieve sunshine duration using nemsio + VarName='sunsd' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,suntime) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,suntime(isa,jsa) + +! retrieve field capacity using nemsio + VarName='fldcp' + VcoordName='sfc' + l=1 + call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,fieldcapa) +! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa) + +! GFS does not have deep convective cloud top and bottom fields + +!$omp parallel do private(i,j) + do j=jsta,jend + do i=1,im + HTOPD(i,j) = SPVAL + HBOTD(i,j) = SPVAL + HTOPS(i,j) = SPVAL + HBOTS(i,j) = SPVAL + CUPPT(i,j) = SPVAL + enddo + enddo + +! +!!!! DONE GETTING +! Will derive isobaric OMEGA from continuity equation later. +! OMGA=SPVAL +! +! +! retrieve d3d fields if it's listed +! ---------------------------------- + if (me == 0) print*,'iostatus for d3d file= ',iostatusD3D + if(iostatusD3D == 0) then ! start reading d3d file +! retrieve longwave tendency using getgb + Index=41 + VarName=avbl(index) + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=is(index) + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,rlwtt(1,jsta_2l,ll)) + end do + +! retrieve shortwave tendency using getgb + Index=40 + VarName=avbl(index) + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=is(index) + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,rswtt(1,jsta_2l,ll)) + end do + +! retrieve vertical diffusion tendency using getgb + Index=356 + VarName='VDIFF TNDY' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,vdifftt(1,jsta_2l,ll)) + end do + +! retrieve deep convective tendency using getgb + Index=79 + VarName=avbl(index) + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=is(index) + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,tcucn(1,jsta_2l,ll)) + end do + +! retrieve shallow convective tendency using getgb + Index=358 + VarName='S CNVCT TNDY' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,tcucns(1,jsta_2l,ll)) + end do + +! retrieve grid scale latent heat tendency using getgb + Index=78 + VarName=avbl(index) + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=is(index) + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,train(1,jsta_2l,ll)) + end do + +! retrieve vertical diffusion moistening using getgb + Index=360 + VarName='Vertical diffusion moistening' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,vdiffmois(1,jsta_2l,ll)) + end do + +! retrieve deep convection moistening using getgb + Index=361 + VarName='deep convection moistening' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,dconvmois(1,jsta_2l,ll)) + end do + +! retrieve shallow convection moistening using getgb + Index=362 + VarName='shallow convection moistening' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,sconvmois(1,jsta_2l,ll)) + end do + +! retrieve non-radiation tendency using getgb + Index=363 + VarName='non-radiation tendency' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,nradtt(1,jsta_2l,ll)) + end do + +! retrieve Vertical diffusion of ozone using getgb + Index=364 + VarName='Vertical diffusion of ozone' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,o3vdiff(1,jsta_2l,ll)) + end do + +! retrieve ozone production using getgb + Index=365 + VarName='Ozone production' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,o3prod(1,jsta_2l,ll)) + end do + +! retrieve ozone tendency using getgb + Index=366 + VarName='Ozone tendency' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,o3tndy(1,jsta_2l,ll)) + end do + +! retrieve mass weighted PV using getgb + Index=367 + VarName='Mass weighted PV' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,mwpv(1,jsta_2l,ll)) + end do + +! retrieve OZONE TNDY using getgb + Index=368 + VarName='?' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,unknown(1,jsta_2l,ll)) + end do + +! retrieve vertical diffusion zonal acceleration + Index=369 + VarName='VDIFF Z ACCE' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,vdiffzacce(1,jsta_2l,ll)) + end do + +! retrieve gravity drag zonal acceleration + Index=370 + VarName='G DRAG Z ACCE' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,zgdrag(1,jsta_2l,ll)) + end do + +! retrieve convective U momemtum mixing + Index=371 + VarName='CNVCT U M MIX' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,cnvctummixing(1,jsta_2l,ll)) + end do + +! retrieve vertical diffusion meridional acceleration + Index=372 + VarName='VDIFF M ACCE' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,vdiffmacce(1,jsta_2l,ll)) + end do + +! retrieve gravity drag meridional acceleration + Index=373 + VarName='G DRAG M ACCE' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,mgdrag(1,jsta_2l,ll)) + end do + +! retrieve convective V momemtum mixing + Index=374 + VarName='CNVCT V M MIX' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,cnvctvmmixing(1,jsta_2l,ll)) + end do + +! retrieve nonconvective cloud fraction + Index=375 + VarName='N CNVCT CLD FRA' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,ncnvctcfrac(1,jsta_2l,ll)) + end do + +! retrieve convective upward mass flux + Index=391 + VarName='CNVCT U M FLX' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,cnvctumflx(1,jsta_2l,ll)) + end do + +! retrieve convective downward mass flux + Index=392 + VarName='CNVCT D M FLX' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,cnvctdmflx(1,jsta_2l,ll)) + end do + +! retrieve nonconvective detraintment flux + Index=393 + VarName='CNVCT DET M FLX' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,cnvctdetmflx(1,jsta_2l,ll)) + end do + +! retrieve cnvct gravity drag zonal acceleration + Index=394 + VarName='CNVCT G DRAG Z ACCE' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,cnvctzgdrag(1,jsta_2l,ll)) + end do + +! retrieve cnvct gravity drag meridional acceleration + Index=395 + VarName='CNVCT G DRAG M ACCE' + jpds=-1.0 + jgds=-1.0 + jpds(5)=iq(index) + jpds(6)=109 + do l=1,lm + jpds(7)=l + ll=lm-l+1 !flip 3d fields to count from top down + call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & + ,jpds,jgds,kpds,cnvctmgdrag(1,jsta_2l,ll)) + end do + + call baclose(iunitd3d,status) + print*,'done reading D3D fields' + + end if ! end of d3d file read + ! -------------------- + print *,'after d3d files reading,mype=',me + +! Retrieve aer fields if it's listed (GOCART) + print *, 'iostatus for aer file=', iostatusAER + if(iostatusAER == 0) then ! start reading aer file + +! retrieve dust emission fluxes + do K = 1, nbin_du + if ( K == 1) VarName='DUEM001' + if ( K == 2) VarName='DUEM002' + if ( K == 3) VarName='DUEM003' + if ( K == 4) VarName='DUEM004' + if ( K == 5) VarName='DUEM005' + VcoordName='atmos col' + l=1 + call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,duem(1,jsta_2l,K)) +! if(debugprint)print*,'sample ',VarName,' = ',duem(isa,jsa,k) + enddo + +! retrieve dust sedimentation fluxes + do K = 1, nbin_du + if ( K == 1) VarName='DUSD001' + if ( K == 2) VarName='DUSD002' + if ( K == 3) VarName='DUSD003' + if ( K == 4) VarName='DUSD004' + if ( K == 5) VarName='DUSD005' + VcoordName='atmos col' + l=1 + call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,dusd(1,jsta_2l,K)) +! if(debugprint)print*,'sample ',VarName,' = ',dusd(isa,jsa,k) + enddo + +! retrieve dust dry deposition fluxes + do K = 1, nbin_du + if ( K == 1) VarName='DUDP001' + if ( K == 2) VarName='DUDP002' + if ( K == 3) VarName='DUDP003' + if ( K == 4) VarName='DUDP004' + if ( K == 5) VarName='DUDP005' + VcoordName='atmos col' + l=1 + call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,dudp(1,jsta_2l,K)) + print *,'dudp,ck=',maxval(dudp(1:im,jsta:jend,k)), & + minval(dudp(1:im,jsta:jend,k)) +! if(debugprint)print*,'sample ',VarName,' = ',dudp(isa,jsa,k) + enddo + +! retrieve dust wet deposition fluxes + do K = 1, nbin_du + if ( K == 1) VarName='DUWT001' + if ( K == 2) VarName='DUWT002' + if ( K == 3) VarName='DUWT003' + if ( K == 4) VarName='DUWT004' + if ( K == 5) VarName='DUWT005' + VcoordName='atmos col' + l=1 + call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,duwt(1,jsta_2l,K)) +! if(debugprint)print*,'sample ',VarName,' = ',duwt(isa,jsa,k) + enddo + +! retrieve sfc mass concentration + VarName='DUSMASS' + VcoordName='atmos col' + l=1 + call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,dusmass) +! if(debugprint)print*,'sample ',VarName,' = ',dusmass(isa,jsa) + +! retrieve col mass density + VarName='DUCMASS' + VcoordName='atmos col' + l=1 + call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,ducmass) +! if(debugprint)print*,'sample ',VarName,' = ',ducmass(isa,jsa) + +! retrieve sfc mass concentration (pm2.5) + VarName='DUSMASS25' + VcoordName='atmos col' + l=1 + call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,dusmass25) +! if(debugprint)print*,'sample ',VarName,' = ',dusmass25(isa,jsa) + +! retrieve col mass density (pm2.5) + VarName='DUCMASS25' + VcoordName='atmos col' + l=1 + call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & + ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & + ,l,im,jm,nframe,ducmass25) +! if(debugprint)print*,'sample ',VarName,' = ',ducmass25(isa,jsa) + + if (me == 0) print *,'after aer files reading,mype=',me + end if ! end of aer file read + +! pos east + call collect_loc(gdlat,dummy) + if(me == 0)then + latstart = nint(dummy(1,1)*gdsdegr) + latlast = nint(dummy(im,jm)*gdsdegr) + print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,& + 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1) + end if + call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) + call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) + write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me + call collect_loc(gdlon,dummy) + if(me == 0)then + lonstart = nint(dummy(1,1)*gdsdegr) + lonlast = nint(dummy(im,jm)*gdsdegr) + end if + call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) + call mpi_bcast(lonlast, 1,MPI_INTEGER,0,mpi_comm_comp,irtn) + + write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast +! +! ncdump -h +!! +!! + write(6,*) 'filename in INITPOST=', filename,' is' + +! status=nf_open(filename,NF_NOWRITE,ncid) +! write(6,*) 'returned ncid= ', ncid +! status=nf_get_att_real(ncid,varid,'DX',tmp) +! dxval=int(tmp) +! status=nf_get_att_real(ncid,varid,'DY',tmp) +! dyval=int(tmp) +! status=nf_get_att_real(ncid,varid,'CEN_LAT',tmp) +! cenlat=int(1000.*tmp) +! status=nf_get_att_real(ncid,varid,'CEN_LON',tmp) +! cenlon=int(1000.*tmp) +! status=nf_get_att_real(ncid,varid,'TRUELAT1',tmp) +! truelat1=int(1000.*tmp) +! status=nf_get_att_real(ncid,varid,'TRUELAT2',tmp) +! truelat2=int(1000.*tmp) +! status=nf_get_att_real(ncid,varid,'MAP_PROJ',tmp) +! maptype=int(tmp) +! status=nf_close(ncid) + +! dxval=30000. +! dyval=30000. +! +! write(6,*) 'dxval= ', dxval +! write(6,*) 'dyval= ', dyval +! write(6,*) 'cenlat= ', cenlat +! write(6,*) 'cenlon= ', cenlon +! write(6,*) 'truelat1= ', truelat1 +! write(6,*) 'truelat2= ', truelat2 +! write(6,*) 'maptype is ', maptype +! + +! close up shop +! call ext_int_ioclose ( DataHandle, Status ) + +! generate look up table for lifted parcel calculations + + THL = 210. + PLQ = 70000. + pt_TBL = 10000. ! this is for 100 hPa added by Moorthi + + CALL TABLE(PTBL,TTBL,PT_TBL, & + RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) + + CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) + +! +! + IF(ME == 0)THEN + WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' + WRITE(6,51) (SPL(L),L=1,LSM) + 50 FORMAT(14(F4.1,1X)) + 51 FORMAT(8(F8.1,1X)) + ENDIF +! +! COMPUTE DERIVED TIME STEPPING CONSTANTS. +! +!MEB need to get DT +! DT = 120. !MEB need to get DT +! NPHS = 4 !MEB need to get physics DT +! TPREC=float(ifhr) +!MEB need to get DT + +!how am i going to get this information? +! NPREC = INT(TPREC *TSPH+D50) +! NHEAT = INT(THEAT *TSPH+D50) +! NCLOD = INT(TCLOD *TSPH+D50) +! NRDSW = INT(TRDSW *TSPH+D50) +! NRDLW = INT(TRDLW *TSPH+D50) +! NSRFC = INT(TSRFC *TSPH+D50) +!how am i going to get this information? +! +! IF(ME == 0)THEN +! WRITE(6,*)' ' +! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS' +! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC +! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW +! ENDIF +! +! COMPUTE DERIVED MAP OUTPUT CONSTANTS. +!$omp parallel do private(l) + DO L = 1,LSM + ALSL(L) = LOG(SPL(L)) + END DO +! +!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN + if(me == 0)then + print*,'writing out igds' + igdout = 110 +! open(igdout,file='griddef.out',form='unformatted' +! + ,status='unknown') + if(maptype == 1)THEN ! Lambert conformal + WRITE(igdout)3 + WRITE(6,*)'igd(1)=',3 + WRITE(igdout)im + WRITE(igdout)jm + WRITE(igdout)LATSTART + WRITE(igdout)LONSTART + WRITE(igdout)8 + WRITE(igdout)CENLON + WRITE(igdout)DXVAL + WRITE(igdout)DYVAL + WRITE(igdout)0 + WRITE(igdout)64 + WRITE(igdout)TRUELAT2 + WRITE(igdout)TRUELAT1 + WRITE(igdout)255 + ELSE IF(MAPTYPE == 2)THEN !Polar stereographic + WRITE(igdout)5 + WRITE(igdout)im + WRITE(igdout)jm + WRITE(igdout)LATSTART + WRITE(igdout)LONSTART + WRITE(igdout)8 + WRITE(igdout)CENLON + WRITE(igdout)DXVAL + WRITE(igdout)DYVAL + WRITE(igdout)0 + WRITE(igdout)64 + WRITE(igdout)TRUELAT2 !Assume projection at +-90 + WRITE(igdout)TRUELAT1 + WRITE(igdout)255 + ! Note: The calculation of the map scale factor at the standard + ! lat/lon and the PSMAPF + ! Get map factor at 60 degrees (N or S) for PS projection, which will + ! be needed to correctly define the DX and DY values in the GRIB GDS + if (TRUELAT1 < 0.) THEN + LAT = -60. + else + LAT = 60. + end if + + CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF) + + ELSE IF(MAPTYPE == 3) THEN !Mercator + WRITE(igdout)1 + WRITE(igdout)im + WRITE(igdout)jm + WRITE(igdout)LATSTART + WRITE(igdout)LONSTART + WRITE(igdout)8 + WRITE(igdout)latlast + WRITE(igdout)lonlast + WRITE(igdout)TRUELAT1 + WRITE(igdout)0 + WRITE(igdout)64 + WRITE(igdout)DXVAL + WRITE(igdout)DYVAL + WRITE(igdout)255 + ELSE IF(MAPTYPE == 0 .OR. MAPTYPE == 203)THEN !A STAGGERED E-GRID + WRITE(igdout)203 + WRITE(igdout)im + WRITE(igdout)jm + WRITE(igdout)LATSTART + WRITE(igdout)LONSTART + WRITE(igdout)136 + WRITE(igdout)CENLAT + WRITE(igdout)CENLON + WRITE(igdout)DXVAL + WRITE(igdout)DYVAL + WRITE(igdout)64 + WRITE(igdout)0 + WRITE(igdout)0 + WRITE(igdout)0 + END IF + end if +! +! close all files +! + call nemsio_close(nfile,iret=status) + call nemsio_close(ffile,iret=status) + call nemsio_close(rfile,iret=status) +! call baclose(iunit,status) + + RETURN + END + + diff --git a/sorc/ncep_post.fd/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f index b675cd6f5..8c74e8304 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -743,8 +743,8 @@ PROGRAM WRFPOST CALL INITPOST_NEMS(NREC,nfile) ELSE IF(MODELNAME == 'GFS') THEN ! CALL INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,nfile,ffile) - CALL INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,iostatusAER, & - nfile,ffile,rfile) +! CALL INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,iostatusAER, & +! nfile,ffile,rfile) ELSE PRINT*,'POST does not have nemsio option for model,',MODELNAME,' STOPPING,' STOP 9998 @@ -770,7 +770,7 @@ PROGRAM WRFPOST END IF ELSE IF(TRIM(IOFORM) == 'sigio')THEN IF(MODELNAME == 'GFS') THEN - CALL INITPOST_GFS_SIGIO(lusig,iunit,iostatusFlux,iostatusD3D,idrt,sighead) +! CALL INITPOST_GFS_SIGIO(lusig,iunit,iostatusFlux,iostatusD3D,idrt,sighead) ELSE PRINT*,'POST does not have sigio option for this model, STOPPING' STOP 99981 diff --git a/sorc/ncep_post.fd/makefile_dtc b/sorc/ncep_post.fd/makefile_dtc index 421670445..b4ed073bb 100644 --- a/sorc/ncep_post.fd/makefile_dtc +++ b/sorc/ncep_post.fd/makefile_dtc @@ -75,8 +75,8 @@ OBJS_F = VRBLS2D_mod.o VRBLS3D_mod.o VRBLS4D_mod.o MASKS_mod.o PMICRPH.o SOIL_m CALGUST.o WETFRZLVL.o SNFRAC.o MDL2AGL.o SNFRAC_GFS.o AVIATION.o DEALLOCATE.o \ CALPBL.o MDL2SIGMA2.o INITPOST_GFS.o CALRH_GFS.o LFMFLD_GFS.o \ CALRAD_WCLOUD_newcrtm.o MDL2THANDPV.o CALPBLREGIME.o POLEAVG.o INITPOST_NEMS.o \ - GETNEMSNDSCATTER.o ICAOHEIGHT.o INITPOST_GFS_NEMS.o \ - GEO_ZENITH_ANGLE.o GFIP3.o GRIDAVG.o CALUPDHEL.o MSFPS.o INITPOST_GFS_SIGIO.o\ + GETNEMSNDSCATTER.o ICAOHEIGHT.o \ + GEO_ZENITH_ANGLE.o GFIP3.o GRIDAVG.o CALUPDHEL.o MSFPS.o \ AllGETHERV_GSD.o SELECT_CHANNELS.o ALLOCATE_ALL.o INITPOST_NEMS_MPIIO.o ASSIGNNEMSIOVAR.o INITPOST_GFS_NEMS_MPIIO.o \ INITPOST_NETCDF.o INITPOST_GFS_NETCDF.o \ gtg_ctlblk.o gtg_indices.o gtg_filter.o gtg_compute.o gtg_config.o map_routines.o gtg_algo.o CALVESSEL.o \ diff --git a/sorc/ncep_post.fd/makefile_module b/sorc/ncep_post.fd/makefile_module index 649440672..42446e4c2 100644 --- a/sorc/ncep_post.fd/makefile_module +++ b/sorc/ncep_post.fd/makefile_module @@ -92,8 +92,8 @@ OBJS = wrf_io_flags.o getVariable.o getIVariableN.o \ AVIATION.o DEALLOCATE.o \ CALPBL.o MDL2SIGMA2.o INITPOST_GFS.o LFMFLD_GFS.o \ CALRAD_WCLOUD_newcrtm.o MDL2THANDPV.o CALPBLREGIME.o POLEAVG.o \ - INITPOST_NEMS.o GETNEMSNDSCATTER.o ICAOHEIGHT.o INITPOST_GFS_NEMS.o \ - GEO_ZENITH_ANGLE.o GFIP3.o CALUPDHEL.o INITPOST_GFS_SIGIO.o \ + INITPOST_NEMS.o GETNEMSNDSCATTER.o ICAOHEIGHT.o \ + GEO_ZENITH_ANGLE.o GFIP3.o CALUPDHEL.o \ AllGETHERV_GSD.o MSFPS.o SELECT_CHANNELS.o ALLOCATE_ALL.o INITPOST_NEMS_MPIIO.o ASSIGNNEMSIOVAR.o \ INITPOST_GFS_NEMS_MPIIO.o INITPOST_NETCDF.o INITPOST_GFS_NETCDF.o INITPOST_GFS_NETCDF_PARA.o \ gtg_ctlblk.o gtg_indices.o gtg_filter.o gtg_compute.o gtg_config.o map_routines.o gtg_algo.o gtg_smoothseams.o CALVESSEL.o \ From ad88ca07b34af270729bd2051fad379343de2ffd Mon Sep 17 00:00:00 2001 From: wx22mj Date: Thu, 30 Sep 2021 18:28:30 +0000 Subject: [PATCH 36/77] 20210930 Jesse Meng add George's itag/numx entry and progress on 2D decompose --- sorc/ncep_post.fd/CTLBLK.f | 4 +++- sorc/ncep_post.fd/EXCH.f | 2 +- sorc/ncep_post.fd/MIXLEN.f | 24 +++++++++++++----------- sorc/ncep_post.fd/MPI_FIRST.f | 8 ++++---- sorc/ncep_post.fd/NGMFLD.f | 18 ++++++++++-------- sorc/ncep_post.fd/NGMSLP.f | 5 +++-- sorc/ncep_post.fd/OTLFT.f | 11 ++++++----- sorc/ncep_post.fd/OTLIFT.f | 9 +++++---- sorc/ncep_post.fd/SCLFLD.f | 5 +++-- sorc/ncep_post.fd/SLP_new.f | 1 + sorc/ncep_post.fd/WRFPOST.f | 18 ++++++++++++++++-- 11 files changed, 65 insertions(+), 40 deletions(-) diff --git a/sorc/ncep_post.fd/CTLBLK.f b/sorc/ncep_post.fd/CTLBLK.f index 9550e3cac..2421a07dd 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,7 +55,7 @@ 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,ista,iend, & + 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), & @@ -68,6 +69,7 @@ module CTLBLK_mod integer, allocatable :: icoords(:,:),ibcoords(:,:) real, allocatable :: bufs(:),buff(:) integer , allocatable :: isxa(:),iexa(:),jsxa(:),jexa(:) + integer numx integer, allocatable :: ibufs(:) ! real :: ARDSW, ARDLW, ASRFC, TSRFC,TRDLW,TRDSW,TCLOD,THEAT, & diff --git a/sorc/ncep_post.fd/EXCH.f b/sorc/ncep_post.fd/EXCH.f index e6d916a95..6f9b4f852 100644 --- a/sorc/ncep_post.fd/EXCH.f +++ b/sorc/ncep_post.fd/EXCH.f @@ -301,7 +301,7 @@ subroutine exch_f(a) real,intent(inout) :: a ( im,jsta_2l:jend_2u ) integer status(MPI_STATUS_SIZE) integer ierr, jstam1, jendp1 - write(0,*) ' called EXCH_F GWVX' +! write(0,*) ' called EXCH_F GWVX' ! if ( num_procs == 1 ) return ! 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)1 value ',numx + else + numx=1 ! DEFAULT! REDUCES TO 1D DECOMP IN THIS CASE + backspace(5) + endif +! end decomposition handling code from itag + read(5,111,end=1000) fileName if (me==0) print*,'fileName= ',fileName read(5,113) IOFORM if (me==0) print*,'IOFORM= ',IOFORM From 069a4f939f24443f11e64a350a26c8955321d15e Mon Sep 17 00:00:00 2001 From: wx22mj Date: Fri, 15 Oct 2021 20:19:14 +0000 Subject: [PATCH 37/77] 20211015 Jesse Meng progress on 2D DECOMPOSITION --- sorc/ncep_post.fd/CALMCVG.f | 37 +- sorc/ncep_post.fd/DEWPOINT.f | 9 +- sorc/ncep_post.fd/ETAMP_Q2F.f | 9 +- sorc/ncep_post.fd/FDLVL.f | 65 +- sorc/ncep_post.fd/FIXED.f | 57 +- sorc/ncep_post.fd/FRZLVL.f | 7 +- sorc/ncep_post.fd/FRZLVL2.f | 7 +- sorc/ncep_post.fd/ICAOHEIGHT.f | 8 +- sorc/ncep_post.fd/LFMFLD.f | 11 +- sorc/ncep_post.fd/LFMFLD_GFS.f | 8 +- sorc/ncep_post.fd/MAPSSLP.f | 15 +- sorc/ncep_post.fd/MDL2AGL.f | 186 ++--- sorc/ncep_post.fd/MDL2P.f | 16 +- sorc/ncep_post.fd/MDL2SIGMA.f | 166 ++-- sorc/ncep_post.fd/MDL2SIGMA2.f | 18 +- sorc/ncep_post.fd/MDL2STD_P.f | 122 +-- sorc/ncep_post.fd/MDLFLD.f | 2 +- sorc/ncep_post.fd/MISCLN.f | 1342 ++++++++++++++++++-------------- sorc/ncep_post.fd/MPI_FIRST.f | 2 +- sorc/ncep_post.fd/SCLFLD.f | 4 +- 20 files changed, 1148 insertions(+), 943 deletions(-) diff --git a/sorc/ncep_post.fd/CALMCVG.f b/sorc/ncep_post.fd/CALMCVG.f index d2cc4d61b..5b991095f 100644 --- a/sorc/ncep_post.fd/CALMCVG.f +++ b/sorc/ncep_post.fd/CALMCVG.f @@ -23,6 +23,7 @@ !! 06-04-25 H CHUANG - BUG FIXES TO CORECTLY COMPUTE MC AT BOUNDARIES !! 21-04-01 J MENG - COMPUTATION ON DEFINED POINTS ONLY !! 21-09-02 B CUI - REPLACE EXCH_F to EXCH +!! 21-09-30 J MENG - 2D DECOMPOSITION !! !! USAGE: CALL CALMCVG(Q1D,U1D,V1D,QCNVG) !! INPUT ARGUMENT LIST: @@ -57,20 +58,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 ! !*************************************************************************** @@ -81,7 +83,8 @@ SUBROUTINE CALMCVG(Q1D,U1D,V1D,QCNVG) ! !$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)AERFD CAN BE PROCESSED WHEN NIN=NBIN_DU ! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE +! 21-10-15 JESSE MENG - 2D DECOMPOSITION ! ! USAGE: CALL FDLVL_MASS(ITYPE,NFD,PTFD,HTFD,NIN,QIN,QTYPE,QFD) ! INPUT ARGUMENT LIST: @@ -900,7 +904,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 @@ -918,9 +923,9 @@ SUBROUTINE FDLVL_MASS(ITYPE,NFD,PTFD,HTFD,NIN,QIN,QTYPE,QFD) real, intent(in) :: PTFD(NFD) real,intent(in) :: HTFD(NFD) integer,intent(in) :: NIN - real,intent(in) :: QIN(IM,JSTA:JEND,LM,NIN) + real,intent(in) :: QIN(ISTA:IEND,JSTA:JEND,LM,NIN) character, intent(in) :: QTYPE(NIN) - real,intent(out) :: QFD(IM,JSTA:JEND,NFD,NIN) + real,intent(out) :: QFD(ISTA:IEND,JSTA:JEND,NFD,NIN) ! INTEGER LHL(NFD) @@ -942,7 +947,7 @@ SUBROUTINE FDLVL_MASS(ITYPE,NFD,PTFD,HTFD,NIN,QIN,QTYPE,QFD) DO N=1,NIN DO IFD = 1,NFD DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND QFD(I,J,IFD,N) = SPVAL ENDDO ENDDO @@ -950,13 +955,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 64c549d7c..395f2c91c 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: @@ -50,7 +51,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 @@ -71,21 +72,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 @@ -98,7 +99,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 ! @@ -106,7 +107,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(SICE(I,J) /= SPVAL .AND. SICE(I,J) > 0.1) GRID1(I,J) = 0. @@ -116,7 +117,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 ! @@ -124,14 +125,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 ! @@ -139,14 +140,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 ! @@ -154,14 +155,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 ! @@ -172,7 +173,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 @@ -189,7 +190,7 @@ SUBROUTINE FIXED 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 ! @@ -215,7 +216,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 @@ -233,14 +234,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 @@ -251,14 +252,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 @@ -276,7 +277,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 @@ -287,7 +288,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 ! @@ -295,7 +296,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 @@ -312,7 +313,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 @@ -321,14 +322,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 @@ -336,14 +337,14 @@ SUBROUTINE FIXED IF (IGET(248)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = EPSR(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(248)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF diff --git a/sorc/ncep_post.fd/FRZLVL.f b/sorc/ncep_post.fd/FRZLVL.f index d84bd7da4..3ea621c68 100644 --- a/sorc/ncep_post.fd/FRZLVL.f +++ b/sorc/ncep_post.fd/FRZLVL.f @@ -34,6 +34,7 @@ !! 02-01-15 MIKE BALDWIN - WRF VERSION !! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT !! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE +!! 21-10-15 JESSE MENG - 2D DECOMPOSITION !! !! USAGE: CALL FRZLVL(ZFRZ,RHFRZ) !! INPUT ARGUMENT LIST: @@ -70,7 +71,7 @@ SUBROUTINE FRZLVL(ZFRZ,RHFRZ,PFRZL) use vrbls2d, only: fis, tshltr, pshltr, qshltr use masks, only: lmh use params_mod, only: gi, d00, capa, d0065, tfrz, pq0, a2, a3, a4 - use ctlblk_mod, only: jsta, jend, spval, lm, modelname, im + use ctlblk_mod, only: jsta, jend, spval, lm, modelname, im, ista, iend use physcons_post, only: con_rd, con_rv, con_eps, con_epsm1 use upp_physics, only: FPVSNEW @@ -78,7 +79,7 @@ SUBROUTINE FRZLVL(ZFRZ,RHFRZ,PFRZL) ! ! DECLARE VARIABLES. ! - REAL,dimension(im,jsta:jend) :: RHFRZ, ZFRZ, PFRZL + REAL,dimension(ista:iend,jsta:jend) :: RHFRZ, ZFRZ, PFRZL integer I,J,LLMH,L real HTSFC,PSFC,TSFC,QSFC,QSAT,RHSFC,DELZ,DELT,DELQ,DELALP, & DELZP,ZL,DZABV,QFRZ,ALPL,ALPH,ALPFRZ,PFRZ,QSFRZ,RHZ,ZU, & @@ -98,7 +99,7 @@ SUBROUTINE FRZLVL(ZFRZ,RHFRZ,PFRZL) ! & zl,zu) DO 20 J=JSTA,JEND - DO 20 I=1,IM + DO 20 I=ISTA,IEND HTSFC = FIS(I,J)*GI LLMH = NINT(LMH(I,J)) RHFRZ(I,J) = D00 diff --git a/sorc/ncep_post.fd/FRZLVL2.f b/sorc/ncep_post.fd/FRZLVL2.f index a8f934ea7..04b86483a 100644 --- a/sorc/ncep_post.fd/FRZLVL2.f +++ b/sorc/ncep_post.fd/FRZLVL2.f @@ -38,6 +38,7 @@ !! 16-01-21 C. Alexander - Generalized function for any isotherm !! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE !! 21-07-28 W. Meng - Restrict compuatation from undefined grids +!! 21-10-15 JESSE MENG - 2D DECOMPOSITION !! !! USAGE: CALL FRZLVL2(ISOTHERM,ZFRZ,RHFRZ,PFRZL) !! INPUT ARGUMENT LIST: @@ -68,7 +69,7 @@ SUBROUTINE FRZLVL2(ISOTHERM,ZFRZ,RHFRZ,PFRZL) use vrbls2d, only: fis, tshltr, pshltr, qz0, qs, qshltr use masks, only: lmh, sm use params_mod, only: gi, d00, capa, d0065, tfrz, pq0, a2, a3, a4, d50 - use ctlblk_mod, only: jsta, jend, spval, lm, modelname, im + use ctlblk_mod, only: jsta, jend, spval, lm, modelname, im, ista, iend use physcons_post, only: con_rd, con_rv, con_eps, con_epsm1 use upp_physics, only: FPVSNEW @@ -81,7 +82,7 @@ SUBROUTINE FRZLVL2(ISOTHERM,ZFRZ,RHFRZ,PFRZL) ! REAL,PARAMETER::PUCAP=300.0E2 real,intent(in) :: ISOTHERM - REAL,dimension(im,jsta:jend),intent(out) :: RHFRZ, ZFRZ, PFRZL + REAL,dimension(ista:iend,jsta:jend),intent(out) :: RHFRZ, ZFRZ, PFRZL !jw integer I,J,L,LICE,LLMH real HTSFC,PSFC,QSFC,RHSFC,QW,QSAT,DELZ,DELT,DELQ,DELALP,DELZP, & @@ -95,7 +96,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/LFMFLD.f b/sorc/ncep_post.fd/LFMFLD.f index a5d83919b..7d5a57769 100644 --- a/sorc/ncep_post.fd/LFMFLD.f +++ b/sorc/ncep_post.fd/LFMFLD.f @@ -40,7 +40,8 @@ !! 00-01-04 JIM TUCCILLO - MPI VERSION !! 02-04-24 MIKE BALDWIN - WRF VERSION !! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT -!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE +!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE +!! 21-10-14 JESSE MENG - 2D DECOMPOSITION !! !! !! USAGE: CALL LFMFLD(RH3310,RH6610,RH3366,PW3310) @@ -73,7 +74,7 @@ SUBROUTINE LFMFLD(RH3310,RH6610,RH3366,PW3310) use vrbls3d, only: pint, alpint, zint, t, q, cwm use masks, only: lmh use params_mod, only: d00, d50, pq0, a2, a3, a4, h1, d01, gi - use ctlblk_mod, only: jsta, jend, modelname, spval, im + use ctlblk_mod, only: jsta, jend, modelname, spval, im, ista, iend use physcons_post, only: con_rd, con_rv, con_eps, con_epsm1 use upp_physics, only: FPVSNEW @@ -86,8 +87,8 @@ SUBROUTINE LFMFLD(RH3310,RH6610,RH3366,PW3310) ! DECLARE VARIABLES. ! REAL ALPM, DZ, ES, PM, PWSUM, QM, QS, TM, DP, RH - REAL,dimension(IM,jsta:jend),intent(inout) :: RH3310, RH6610, RH3366 - REAL,dimension(IM,jsta:jend),intent(inout) :: PW3310 + REAL,dimension(ista:iend,jsta:jend),intent(inout) :: RH3310, RH6610, RH3366 + REAL,dimension(ista:iend,jsta:jend),intent(inout) :: PW3310 real Z3310,Z6610,Z3366,P10,P33,P66 integer I,J,L,LLMH ! @@ -98,7 +99,7 @@ SUBROUTINE LFMFLD(RH3310,RH6610,RH3366,PW3310) ! LOOP OVER HORIZONTAL GRID. ! DO 30 J=JSTA,JEND - DO 30 I=1,IM + DO 30 I=ISTA,IEND ! ! ZERO VARIABLES. RH3310(I,J) = D00 diff --git a/sorc/ncep_post.fd/LFMFLD_GFS.f b/sorc/ncep_post.fd/LFMFLD_GFS.f index e89436e39..09cc285f9 100644 --- a/sorc/ncep_post.fd/LFMFLD_GFS.f +++ b/sorc/ncep_post.fd/LFMFLD_GFS.f @@ -44,7 +44,7 @@ !! RATHER THAN DZ !! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT !! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE -!! +!! 21-10-14 JESSE MENG - 2D DECOMPOSITION !! !! USAGE: CALL LFMFLD(RH3310,RH6610,RH3366,PW3310) !! INPUT ARGUMENT LIST: @@ -76,7 +76,7 @@ SUBROUTINE LFMFLD_GFS(RH4410,RH7294,RH4472,RH3310) use vrbls3d, only: pint, q, t, pmid use masks, only: lmh use params_mod, only: d00 - use ctlblk_mod, only: jsta, jend, spval, im + use ctlblk_mod, only: jsta, jend, spval, im, ista, iend use upp_physics, only: FPVSNEW ! implicit none @@ -92,7 +92,7 @@ SUBROUTINE LFMFLD_GFS(RH4410,RH7294,RH4472,RH3310) ! DECLARE VARIABLES. ! REAL ALPM, DZ, ES, PM, PWSUM, QM, QS - REAL,dimension(IM,jsta:jend),intent(out) :: RH4410, RH7294, RH4472 & + REAL,dimension(ista:iend,jsta:jend),intent(out) :: RH4410, RH7294, RH4472 & ,RH3310 ! integer I,J,L,LLMH @@ -106,7 +106,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 3b0728a8f..4ef1d8a44 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. .and. TPRES(I,J,L) 100.) THEN @@ -110,7 +111,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 bf761b170..757a1727e 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -798,7 +798,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(gridtype == 'E')THEN DO J=JSTA,JEND ! DO I=2,IM-MOD(J,2) - DO I=ISTA,IEND + 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) @@ -848,13 +848,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) & @@ -873,7 +873,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! DO J=JSTA,JEND ! DO I=1,IM-MOD(j,2) - DO I=ISTA,IEND + DO I=ISTA,IEND-MOD(j,2) LL = NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF WINDS FOR A-E GRID @@ -922,8 +922,8 @@ 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 diff --git a/sorc/ncep_post.fd/MDL2SIGMA.f b/sorc/ncep_post.fd/MDL2SIGMA.f index 50bae24bc..e2fd97a36 100644 --- a/sorc/ncep_post.fd/MDL2SIGMA.f +++ b/sorc/ncep_post.fd/MDL2SIGMA.f @@ -20,6 +20,7 @@ !! 11-02064 J WANG - ADD GRIB2 option !! 20-03-25 J MENG - remove grib1 !! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) +!! 21-10-14 J MENG - 2D DECOMPOSITION !! !! USAGE: CALL MDL2P !! INPUT ARGUMENT LIST: @@ -62,7 +63,7 @@ SUBROUTINE MDL2SIGMA h1m12, d00, h2, rd, g, gi, h99999 use ctlblk_mod, only: jsta_2l, jend_2u, spval, lp1, jsta, jend, lm, & grib, cfld, datapd, fld_info, me, jend_m, im, & - jm, im_jm + jm, im_jm, ista, iend, ista_2l, iend_2u, ista_m, iend_m use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml use gridspec_mod, only :gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -80,14 +81,14 @@ SUBROUTINE MDL2SIGMA LOGICAL READTHK LOGICAL IOOMG,IOALL LOGICAL DONEFSL1,TSLDONE - real, dimension(im,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL, Q2SL, & + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL, Q2SL, & FSL1, CFRSIG, EGRID1, EGRID2 REAL GRID1(IM,JM) - real, dimension(im,jsta_2l:jend_2u) :: grid2 + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: grid2 REAL SIGO(LSIG+1),DSIGO(LSIG),ASIGO(LSIG) ! - INTEGER,dimension(im,jsta_2l:jend_2u) :: NL1X,NL1XF + INTEGER,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: NL1X,NL1XF ! ! !--- Definition of the following 2D (horizontal) dummy variables @@ -98,7 +99,7 @@ SUBROUTINE MDL2SIGMA ! QR1 - rain mixing ratio ! QS1 - snow mixing ratio ! - real, dimension(im,jsta_2l:jend_2u) :: C1D, QW1, QI1, QR1, QS1, QG1, AKH + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: C1D, QW1, QI1, QR1, QS1, QG1, AKH ! integer I,J,L,LL,LP,LLMH,II,JJ,JJB,JJE,NHOLD real PFSIGO,APFSIGO,PSIGO,APSIGO,PNL1,PU,ZU,TU,QU,QSAT, & @@ -196,7 +197,7 @@ SUBROUTINE MDL2SIGMA END IF ! OBTAIN GEOPOTENTIAL AT 1ST LEVEL 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 @@ -208,7 +209,7 @@ SUBROUTINE MDL2SIGMA END DO END DO DO 167 J=JSTA,JEND - DO 167 I=1,IM + DO 167 I=ISTA_2L,IEND_2U DONEFSL1=.FALSE. PFSIGO=PTSIGO APFSIGO=LOG(PFSIGO) @@ -309,7 +310,7 @@ SUBROUTINE MDL2SIGMA IF (LVLS(1,IGET(205))>0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FSL1(I,J)0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=AKH(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(243)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif if(me==0)print*,'output Heat Diffusivity' @@ -353,7 +354,7 @@ SUBROUTINE MDL2SIGMA NHOLD=0 ! DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U ! TSL(I,J)=SPVAL @@ -407,7 +408,7 @@ SUBROUTINE MDL2SIGMA !hc J=JHOLD(NN) DO 220 J=JSTA,JEND ! Moorthi on Nov 26 2014 ! DO 220 J=JSTA_2L,JEND_2U - DO 220 I=1,IM + DO 220 I=ISTA,IEND LL=NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -555,7 +556,7 @@ SUBROUTINE MDL2SIGMA ! ! OBTAIN GEOPOTENTIAL AND KH ON INTERFACES DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U FSL(I,J)=SPVAL AKH(I,J)=SPVAL NL1XF(I,J)=LP1 @@ -571,7 +572,7 @@ SUBROUTINE MDL2SIGMA ! ! DO J=JSTA_2L,JEND_2U DO J=JSTA,JEND ! Moorthi on 26 Nov 2014 - DO I=1,IM + DO I=ISTA,IEND DONEFSL1=.FALSE. TSLDONE=.FALSE. LLMH = NINT(LMH(I,J)) @@ -721,22 +722,41 @@ SUBROUTINE MDL2SIGMA ! VERTICAL INTERPOLATION FOR WIND FOR E and B GRIDS ! if(gridtype=='B' .or. gridtype=='E') & - call exch(PINT(1:IM,JSTA_2L:JEND_2U,LP1)) + call exch(PINT(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LP1)) IF(gridtype=='E')THEN DO J=JSTA,JEND - DO I=1,IM-MOD(J,2) +! DO I=1,IM-MOD(J,2) + DO I=ISTA,IEND-MOD(J,2) !Jesse 20211014 ! !*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. ! LLMH = NINT(LMH(I,J)) - IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC + +!Jesse 20211014 +! IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC +! PDV=0.5*(PINT(I,J,LLMH+1)+PINT(I+1,J,LLMH+1)) +! ELSE IF(J==JM .AND. I0)THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FSL(I,J)0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=AKH(I,J) IF(LP==(LSIG+1))GRID1(I,J)=0.0 !! NO SLIP ASSUMTION FOR CMAQ ENDDO @@ -962,7 +1004,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(243)) fld_info(cfld)%lvl=LVLSXML(LP+1,IGET(243)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif if(me==0)print*,'output Heat Diffusivity' ENDIF @@ -973,7 +1015,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(206)>0) THEN IF(LVLS(LP,IGET(206))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=TSL(I,J) ENDDO ENDDO @@ -981,7 +1023,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(206)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(206)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -992,7 +1034,7 @@ SUBROUTINE MDL2SIGMA IF(LVLS(LP,IGET(216))>0)THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LLMH = NINT(LMH(I,J)) GRID1(I,J)=PTSIGO+ASIGO(LP)*(PINT(I,J,LLMH+1)-PTSIGO) ENDDO @@ -1001,7 +1043,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(216)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(216)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1011,7 +1053,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(207)>0)THEN IF(LVLS(LP,IGET(207))>0)THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QSL(I,J) ENDDO ENDDO @@ -1020,7 +1062,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(207)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(207)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1030,7 +1072,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(210)>0)THEN IF(LVLS(LP,IGET(210))>0)THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=OSL(I,J) ENDDO ENDDO @@ -1038,7 +1080,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(210)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(210)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1048,7 +1090,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(208)>0.OR.IGET(209)>0)THEN IF(LVLS(LP,IGET(208))>0.OR.LVLS(LP,IGET(209))>0) then DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=USL(I,J) GRID2(I,J)=VSL(I,J) ENDDO @@ -1057,11 +1099,11 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(208)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(208)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(209)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(209)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID2(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1071,7 +1113,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(217)>0) THEN IF (LVLS(LP,IGET(217))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=Q2SL(I,J) ENDDO ENDDO @@ -1079,7 +1121,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(217)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(217)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1089,7 +1131,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(211)>0) THEN IF (LVLS(LP,IGET(211))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QW1(I,J) ENDDO ENDDO @@ -1097,7 +1139,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(211)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(211)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1107,7 +1149,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(212)>0) THEN IF (LVLS(LP,IGET(212))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QI1(I,J) ENDDO ENDDO @@ -1115,7 +1157,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(212)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(212)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1124,7 +1166,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(213)>0) THEN IF (LVLS(LP,IGET(213))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QR1(I,J) ENDDO ENDDO @@ -1132,7 +1174,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(213)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(213)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1141,7 +1183,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(214)>0) THEN IF (LVLS(LP,IGET(214))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QS1(I,J) ENDDO ENDDO @@ -1149,7 +1191,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(214)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(214)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1158,7 +1200,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(255)>0) THEN IF (LVLS(LP,IGET(255))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QG1(I,J) ENDDO ENDDO @@ -1166,7 +1208,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(255)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(255)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1175,7 +1217,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(215)>0) THEN IF (LVLS(LP,IGET(215))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=C1D(I,J) ENDDO ENDDO @@ -1183,7 +1225,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(215)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(215)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1192,7 +1234,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(222)>0) THEN IF (LVLS(LP,IGET(222))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=CFRSIG(I,J) ENDDO ENDDO @@ -1200,7 +1242,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(222)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(222)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF diff --git a/sorc/ncep_post.fd/MDL2SIGMA2.f b/sorc/ncep_post.fd/MDL2SIGMA2.f index 1efa8da73..a02107e10 100644 --- a/sorc/ncep_post.fd/MDL2SIGMA2.f +++ b/sorc/ncep_post.fd/MDL2SIGMA2.f @@ -20,6 +20,7 @@ !! 20-03-25 J MENG - remove grib1 !! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) !! 21-07-26 W Meng - Restrict compuatation from undefined grids +!! 21-10-14 J MENG - 2D DECOMPOSITION !! !! USAGE: CALL MDL2P !! INPUT ARGUMENT LIST: @@ -50,7 +51,8 @@ SUBROUTINE MDL2SIGMA2 use masks, only: lmh use params_mod, only: pq0, a2, a3, a4, rgamog use ctlblk_mod, only: pt, jsta_2l, jend_2u, spval, lp1, lm, jsta, jend,& - grib, cfld, datapd, fld_info, im, jm, im_jm + grib, cfld, datapd, fld_info, im, jm, im_jm, & + ista, iend, ista_2l, iend_2u use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml ! implicit none @@ -61,12 +63,12 @@ SUBROUTINE MDL2SIGMA2 ! LOGICAL READTHK ! REAL,dimension(im,jm) :: FSL, TSL, QSL, osl, usl, vsl, q2sl, fsl1, & - REAL,dimension(im,jsta_2l:jend_2u) :: TSL - REAL,dimension(im,jsta_2l:jend_2u) :: grid1 + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: TSL + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: grid1 REAL SIGO(LSIG+1),DSIGO(LSIG),ASIGO(LSIG) ! ! INTEGER,dimension(im,jm) :: IHOLD,JHOLD,NL1X,NL1XF - INTEGER,dimension(im,jsta_2l:jend_2u) :: NL1X + INTEGER,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: NL1X ! ! !--- Definition of the following 2D (horizontal) dummy variables @@ -134,7 +136,7 @@ SUBROUTINE MDL2SIGMA2 NHOLD=0 ! DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U ! TSL(I,J)=SPVAL @@ -175,7 +177,7 @@ SUBROUTINE MDL2SIGMA2 ! DO 220 J=JSTA,JEND ! DO 220 J=JSTA_2L,JEND_2U DO 220 J=JSTA,JEND ! Moorthi on Nov 26, 2014 - DO 220 I=1,IM + DO 220 I=ISTA,IEND LL=NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -264,7 +266,7 @@ SUBROUTINE MDL2SIGMA2 IF(IGET(296)>0) THEN IF(LVLS(LP,IGET(296))>0)THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=TSL(I,J) ENDDO ENDDO @@ -272,7 +274,7 @@ SUBROUTINE MDL2SIGMA2 cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(296)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(296)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF diff --git a/sorc/ncep_post.fd/MDL2STD_P.f b/sorc/ncep_post.fd/MDL2STD_P.f index bcb81f375..813322621 100644 --- a/sorc/ncep_post.fd/MDL2STD_P.f +++ b/sorc/ncep_post.fd/MDL2STD_P.f @@ -12,6 +12,7 @@ !! 20-05-20 J MENG - CALRH unification with NAM scheme !! 20-11-10 J MENG - USE UPP_PHYSICS MODULE !! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) +!! 21-10-14 J MENG - 2D DECOMPOSITION !! !! USAGE: CALL MDL2STD_P !! INPUT ARGUMENT LIST: @@ -44,7 +45,8 @@ 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 @@ -55,11 +57,11 @@ SUBROUTINE MDL2STD_P() real, external :: P2H, relabel - real,dimension(im,jsta_2l:jend_2u) :: grid1 - real,dimension(im,jsta_2l:jend_2u) :: EGRID1,EGRID2,EGRID3,EGRID4 + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: grid1 + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: EGRID1,EGRID2,EGRID3,EGRID4 ! - integer I,J,jj,L,ITYPE,IFD,ITYPEFDLVL(NFD) + integer I,J,ii,jj,L,ITYPE,IFD,ITYPEFDLVL(NFD) ! Variables introduced to allow FD levels from control file - Y Mao integer :: N,NFDCTL @@ -119,8 +121,8 @@ SUBROUTINE MDL2STD_P() ENDDO if(allocated(VAR3D1)) deallocate(VAR3D1) if(allocated(VAR3D2)) deallocate(VAR3D2) - allocate(VAR3D1(IM,JSTA_2L:JEND_2U,NFDCTL)) - allocate(VAR3D2(IM,JSTA_2L:JEND_2U,NFDCTL)) + allocate(VAR3D1(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NFDCTL)) + allocate(VAR3D2(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NFDCTL)) VAR3D1=SPVAL VAR3D2=SPVAL @@ -131,7 +133,7 @@ SUBROUTINE MDL2STD_P() IF (LVLS(IFD,IGET(520)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=VAR3D1(I,J,IFD) ENDDO ENDDO @@ -139,11 +141,12 @@ SUBROUTINE MDL2STD_P() cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(520)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(520)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -152,7 +155,7 @@ SUBROUTINE MDL2STD_P() IF (LVLS(IFD,IGET(521)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=VAR3D2(I,J,IFD) ENDDO ENDDO @@ -160,23 +163,24 @@ SUBROUTINE MDL2STD_P() cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(521)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(521)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif ENDIF ! ABSV IF (LVLS(IFD,IGET(524)) > 0) THEN - EGRID1=VAR3D1(1:IM,JSTA_2L:JEND_2U,IFD) - EGRID2=VAR3D2(1:IM,JSTA_2L:JEND_2U,IFD) + EGRID1=VAR3D1(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,IFD) + EGRID2=VAR3D2(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,IFD) call CALVOR(EGRID1,EGRID2,EGRID3) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=EGRID3(I,J) ENDDO ENDDO @@ -184,11 +188,12 @@ SUBROUTINE MDL2STD_P() cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(524)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(524)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -206,7 +211,7 @@ SUBROUTINE MDL2STD_P() if(allocated(QIN)) deallocate(QIN) if(allocated(QTYPE)) deallocate(QTYPE) - ALLOCATE(QIN(IM,JSTA:JEND,LM,NFDMAX)) + ALLOCATE(QIN(ISTA:IEND,JSTA:JEND,LM,NFDMAX)) ALLOCATE(QTYPE(NFDMAX)) ! INITIALIZE INPUTS @@ -214,53 +219,53 @@ SUBROUTINE MDL2STD_P() IF(IGET(450) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 450 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=icing_gfip(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=icing_gfip(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="O" end if IF(IGET(480) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 480 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=icing_gfis(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=icing_gfis(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="O" end if IF(IGET(464) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 464 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=gtg(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=gtg(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="O" end if IF(IGET(465) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 465 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=catedr(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=catedr(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="O" end if IF(IGET(466) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 466 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=mwt(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=mwt(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="O" end if IF(IGET(519) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 519 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=T(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=T(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="T" end if IF(IGET(523) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 523 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=OMGA(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=OMGA(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="W" end if IF(IGET(525) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 525 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=QQW(1:IM,JSTA:JEND,1:LM)+ & - QQR(1:IM,JSTA:JEND,1:LM)+ & - QQS(1:IM,JSTA:JEND,1:LM)+ & - QQG(1:IM,JSTA:JEND,1:LM)+ & - QQI(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=QQW(ISTA:IEND,JSTA:JEND,1:LM)+ & + QQR(ISTA:IEND,JSTA:JEND,1:LM)+ & + QQS(ISTA:IEND,JSTA:JEND,1:LM)+ & + QQG(ISTA:IEND,JSTA:JEND,1:LM)+ & + QQI(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="C" end if @@ -281,7 +286,7 @@ SUBROUTINE MDL2STD_P() ENDDO if(allocated(QFD)) deallocate(QFD) - ALLOCATE(QFD(IM,JSTA:JEND,NFDCTL,nFDS)) + ALLOCATE(QFD(ISTA:IEND,JSTA:JEND,NFDCTL,nFDS)) QFD=SPVAL call FDLVL_MASS(ITYPEFDLVLCTL,NFDCTL,pset%param(N)%level,HTFDCTL,nFDS,QIN,QTYPE,QFD) @@ -296,7 +301,7 @@ SUBROUTINE MDL2STD_P() N1=N DO IFD = 1,NFDCTL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(QFD(I,J,IFD,N) < SPVAL) then QFD(I,J,IFD,N)=max(0.0,QFD(I,J,IFD,N)) QFD(I,J,IFD,N)=min(1.0,QFD(I,J,IFD,N)) @@ -311,7 +316,7 @@ SUBROUTINE MDL2STD_P() N1=N DO IFD = 1,NFDCTL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(QFD(I,J,IFD,N) < SPVAL) then QFD(I,J,IFD,N)=max(0.0,QFD(I,J,IFD,N)) endif @@ -330,7 +335,7 @@ SUBROUTINE MDL2STD_P() if(iID==480) then DO IFD = 1,NFDCTL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(N1 > 0) then ! Icing severity is 0 when icing potential is too small if(QFD(I,J,IFD,N1) < 0.001) QFD(I,J,IFD,N)=0. @@ -356,7 +361,7 @@ SUBROUTINE MDL2STD_P() if(iID==464 .or. iID==465 .or. iID==466) then DO IFD = 1,NFDCTL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(QFD(I,J,IFD,N) < SPVAL) then QFD(I,J,IFD,N)=max(0.0,QFD(I,J,IFD,N)) QFD(I,J,IFD,N)=min(1.0,QFD(I,J,IFD,N)) @@ -375,7 +380,7 @@ SUBROUTINE MDL2STD_P() IF (LVLS(IFD,IGET(iID)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QFD(I,J,IFD,N) ENDDO ENDDO @@ -383,11 +388,12 @@ SUBROUTINE MDL2STD_P() cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(iID)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(iID)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -417,7 +423,7 @@ SUBROUTINE MDL2STD_P() IF (LVLS(IFD,IGET(iID)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=HTFDCTL(IFD) ENDDO ENDDO @@ -425,11 +431,12 @@ SUBROUTINE MDL2STD_P() cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(iID)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(iID)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -456,15 +463,15 @@ SUBROUTINE MDL2STD_P() if(allocated(QIN)) deallocate(QIN) if(allocated(QTYPE)) deallocate(QTYPE) - ALLOCATE(QIN(IM,JSTA:JEND,LM,2)) + ALLOCATE(QIN(ISTA:IEND,JSTA:JEND,LM,2)) ALLOCATE(QTYPE(2)) - QIN(1:IM,JSTA:JEND,1:LM,1)=T(1:IM,JSTA:JEND,1:LM) - QIN(1:IM,JSTA:JEND,1:LM,2)=Q(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,1)=T(ISTA:IEND,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,2)=Q(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(1)="T" QTYPE(2)="Q" if(allocated(QFD)) deallocate(QFD) - ALLOCATE(QFD(IM,JSTA:JEND,NFDCTL,2)) + ALLOCATE(QFD(ISTA:IEND,JSTA:JEND,NFDCTL,2)) QFD=SPVAL print *, "wafs levels",pset%param(N)%level @@ -476,20 +483,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,jsta),EGRID3(ista,jsta),EGRID4(ista,jsta),EGRID1(ista,jsta)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(EGRID1(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J)*100. ELSE @@ -502,10 +509,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/MDLFLD.f b/sorc/ncep_post.fd/MDLFLD.f index 4281c21c2..bd932e8d6 100644 --- a/sorc/ncep_post.fd/MDLFLD.f +++ b/sorc/ncep_post.fd/MDLFLD.f @@ -43,7 +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 DECOMPISITION +!! 21-07-07 J MENG - 2D DECOMPOSITION !! !! USAGE: CALL MDLFLD !! INPUT ARGUMENT LIST: diff --git a/sorc/ncep_post.fd/MISCLN.f b/sorc/ncep_post.fd/MISCLN.f index c333ad586..3bca9ebde 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 @@ -307,11 +313,12 @@ SUBROUTINE MISCLN 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,jsta)) ! 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,jsta)) 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,jsta)) ! 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,7 +1497,7 @@ 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 @@ -1460,11 +1506,12 @@ SUBROUTINE MISCLN 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,jsta)) 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,7 +1884,7 @@ 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 @@ -1834,11 +1894,12 @@ SUBROUTINE MISCLN 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,jsta,LBND), QBND(ista,jsta,LBND), & + GRID1(ista,jsta), TBND(ista,jsta,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,jsta)) 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,7 +2611,7 @@ 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 @@ -2541,11 +2621,12 @@ SUBROUTINE MISCLN 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,15 +2692,15 @@ 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 @@ -2627,11 +2710,12 @@ SUBROUTINE MISCLN 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,7 +2727,7 @@ 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 @@ -2653,11 +2737,12 @@ SUBROUTINE MISCLN 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,7 +2752,7 @@ 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 @@ -2677,11 +2762,12 @@ SUBROUTINE MISCLN 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,7 +2814,7 @@ 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 @@ -2737,11 +2824,12 @@ SUBROUTINE MISCLN 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,7 +2839,7 @@ 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 @@ -2761,11 +2849,12 @@ SUBROUTINE MISCLN 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,7 +2864,7 @@ 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 @@ -2785,11 +2874,12 @@ SUBROUTINE MISCLN 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,7 +2889,7 @@ 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 @@ -2809,11 +2899,12 @@ SUBROUTINE MISCLN 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:IEND,JSTA:JEND)) 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 @@ -4521,11 +4652,12 @@ SUBROUTINE MISCLN 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/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 25fbb9bd8..91d73bf52 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -114,7 +114,7 @@ SUBROUTINE MPI_FIRST() ! numx=1 if ( me == 0 ) then -! print *, ' NUM_PROCS = ',num_procs + write(0,*) ' NUM_PROCS,NUMX,NUMY = ',num_procs,numx,num_procs/numx end if if ( num_procs > 1024 ) then diff --git a/sorc/ncep_post.fd/SCLFLD.f b/sorc/ncep_post.fd/SCLFLD.f index 2f43004b4..9c0b2a62c 100644 --- a/sorc/ncep_post.fd/SCLFLD.f +++ b/sorc/ncep_post.fd/SCLFLD.f @@ -43,7 +43,7 @@ SUBROUTINE SCLFLD(FLD,SCALE,IMO,JMO) ! use params_mod, only: small - use ctlblk_mod, only: jsta, jend, ista, iend, spval + use ctlblk_mod, only: jsta, jend, spval, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -62,7 +62,7 @@ SUBROUTINE SCLFLD(FLD,SCALE,IMO,JMO) ! !$omp parallel do DO J=JSTA,JEND - DO I=ISTA,JSTA + DO I=ISTA,IEND IF(ABS(FLD(I,J)-SPVAL)>SMALL) FLD(I,J)=SCALE*FLD(I,J) ENDDO ENDDO From da4158539e7311ee8b95c213e3c1a3c304716cec Mon Sep 17 00:00:00 2001 From: Bo Cui Date: Sun, 17 Oct 2021 16:55:01 -0400 Subject: [PATCH 38/77] 20211017 Bo Cui add new subroutines to UPP 2D decomposition --- sorc/ncep_post.fd/CALGUST.f | 21 ++--- sorc/ncep_post.fd/CALHEL.f | 30 +++---- sorc/ncep_post.fd/CALHEL2.f | 36 ++++---- sorc/ncep_post.fd/CALHEL3.f | 35 ++++---- sorc/ncep_post.fd/CALLCL.f | 15 ++-- sorc/ncep_post.fd/CALVOR.f | 162 ++++++++++++++++++------------------ 6 files changed, 156 insertions(+), 143 deletions(-) diff --git a/sorc/ncep_post.fd/CALGUST.f b/sorc/ncep_post.fd/CALGUST.f index 07c4a7f1c..0ba8eb498 100644 --- a/sorc/ncep_post.fd/CALGUST.f +++ b/sorc/ncep_post.fd/CALGUST.f @@ -15,6 +15,7 @@ !! 15-03-11 S Moorthi - set sfcwind to spval if u10 and v10 are spvals !! for A grid and set gust to just wind !! (in GSM with nemsio, it appears u10 & v10 have spval) +!! 21-09-02 Bo Cui - Decompose UPP in X direction !! !! USAGE: CALL CALGUST(GUST) !! INPUT ARGUMENT LIST: @@ -49,7 +50,7 @@ SUBROUTINE CALGUST(LPBL,ZPBL,GUST) use vrbls2d , only: u10h, v10h, u10,v10, fis use params_mod, only: d25, gi use ctlblk_mod, only: jsta, jend, spval, jsta_m, jend_m, num_procs, mpi_comm_comp, lm,& - modelname, im, jm, jsta_2l, jend_2u + modelname, im, jm, jsta_2l, jend_2u, ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype implicit none @@ -60,9 +61,9 @@ SUBROUTINE CALGUST(LPBL,ZPBL,GUST) ! ! DECLARE VARIABLES. ! - INTEGER,intent(in) :: LPBL(IM,jsta_2l:jend_2u) - REAL,intent(in) :: ZPBL(IM,jsta_2l:jend_2u) - REAL,intent(inout) :: GUST(IM,jsta_2l:jend_2u) + INTEGER,intent(in) :: LPBL(ista_2l:iend_2u,jsta_2l:jend_2u) + REAL,intent(in) :: ZPBL(ista_2l:iend_2u,jsta_2l:jend_2u) + REAL,intent(inout) :: GUST(ista_2l:iend_2u,jsta_2l:jend_2u) integer I,J,IE,IW, L, K, ISTART, ISTOP, JSTART, JSTOP integer LMIN,LXXX,IERR @@ -76,25 +77,25 @@ SUBROUTINE CALGUST(LPBL,ZPBL,GUST) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GUST(I,J) = SPVAL ENDDO ENDDO IF(gridtype == 'A') THEN - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND ELSE - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M if ( num_procs > 1 ) then !CALL EXCH(U10(1,jsta_2l)) !CALL EXCH(V10(1,jsta_2l)) - LMIN = max(1, minval(lpbl(1:im,jsta:jend))) + LMIN = max(1, minval(lpbl(ista:iend,jsta:jend))) CALL MPI_ALLREDUCE(LMIN,LXXX,1,MPI_INTEGER,MPI_MIN,MPI_COMM_COMP,IERR) DO L=LXXX,LM CALL EXCH(UH(1,jsta_2l,L)) diff --git a/sorc/ncep_post.fd/CALHEL.f b/sorc/ncep_post.fd/CALHEL.f index 8520bf5cd..8c11bc24c 100644 --- a/sorc/ncep_post.fd/CALHEL.f +++ b/sorc/ncep_post.fd/CALHEL.f @@ -38,6 +38,7 @@ !! 05=02-25 H CHUANG - ADD COMPUTATION FOR ARW A GRID !! 05-07-07 BINBIN ZHOU - ADD RSM FOR A GRID !! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT +!! 21-09-02 Bo Cui - Decompose UPP in X direction !! !! USAGE: CALHEL(UST,VST,HELI) !! INPUT ARGUMENT LIST: @@ -84,7 +85,8 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) use params_mod, only: g use lookup_mod, only: ITB,JTB,ITBQ,JTBQ use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, jsta_2l, jend_2u, & - lm, im, jm, me, spval + lm, im, jm, me, spval, & + ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -102,10 +104,10 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) ! DECLARE VARIABLES ! real,intent(in) :: DEPTH(2) - REAL,dimension(IM,jsta_2l:jend_2u), intent(out) :: UST,VST - REAL,dimension(IM,jsta_2l:jend_2u,2),intent(out) :: HELI + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: UST,VST + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,2),intent(out) :: HELI ! - real, dimension(im,jsta_2l:jend_2u) :: HTSFC, UST6, VST6, UST5, VST5, & + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: HTSFC, UST6, VST6, UST5, VST5, & UST1, VST1, USHR1, VSHR1, & USHR6, VSHR6, U1, V1, U2, V2, & HGT1, HGT2, UMEAN, VMEAN @@ -120,7 +122,7 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) ! REAL HGT1(IM,JM),HGT2(IM,JM),UMEAN(IM,JM),VMEAN(IM,JM) ! CRA - integer, dimension(im,jsta_2l:jend_2u) :: COUNT6, COUNT5, COUNT1, L1, L2 + integer, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: COUNT6, COUNT5, COUNT1, L1, L2 ! INTEGER COUNT6(IM,JM),COUNT5(IM,JM),COUNT1(IM,JM) ! CRA ! INTEGER L1(IM,JM),L2(IM,JM) @@ -140,7 +142,7 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND UST(I,J) = 0.0 VST(I,J) = 0.0 HELI(I,J,1) = 0.0 @@ -180,8 +182,8 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) IVE(J) = MOD(J,2) IVW(J) = IVE(J)-1 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE IF(gridtype == 'B')THEN @@ -191,8 +193,8 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) IVE(J)=1 IVW(J)=0 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE @@ -202,8 +204,8 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) IVE(J) = 0 IVW(J) = 0 enddo - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND END IF @@ -218,9 +220,9 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) ! END DO ! !!$omp parallel do private(htsfc,ie,iw) - IF(gridtype /= 'A') CALL EXCH(FIS(1:IM,JSTA_2L:JEND_2U)) + IF(gridtype /= 'A') CALL EXCH(FIS(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)) DO L = 1,LM - IF(gridtype /= 'A') CALL EXCH(ZMID(1:IM,JSTA_2L:JEND_2U,L)) + IF(gridtype /= 'A') CALL EXCH(ZMID(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) DO J=JSTART,JSTOP DO I=ISTART,ISTOP IE = I+IVE(J) diff --git a/sorc/ncep_post.fd/CALHEL2.f b/sorc/ncep_post.fd/CALHEL2.f index c7678b1c9..183ebcc2a 100644 --- a/sorc/ncep_post.fd/CALHEL2.f +++ b/sorc/ncep_post.fd/CALHEL2.f @@ -39,6 +39,7 @@ !! 05-07-07 BINBIN ZHOU - ADD RSM FOR A GRID !! 19-09-03 J MENG - MODIFIED TO COMPUTE EFFECTIVE HELICITY !! AND CRITICAL ANGLE +!! 21-09-02 Bo Cui - Decompose UPP in X direction !! !! USAGE: CALHEL(UST,VST,HELI) !! INPUT ARGUMENT LIST: @@ -88,7 +89,8 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) use params_mod, only: g use lookup_mod, only: ITB,JTB,ITBQ,JTBQ use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, jsta_2l, jend_2u, & - lm, im, jm, me, spval + lm, im, jm, me, spval, & + ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -106,17 +108,17 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) ! ! DECLARE VARIABLES ! - integer,dimension(IM,jsta_2l:jend_2u),intent(in) :: LLOW, LUPP + integer,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: LLOW, LUPP real,intent(in) :: DEPTH(2) - REAL,dimension(IM,jsta_2l:jend_2u), intent(out) :: UST,VST - REAL,dimension(IM,jsta_2l:jend_2u,2),intent(out) :: HELI - REAL,dimension(IM,jsta_2l:jend_2u), intent(out) :: CANGLE + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: UST,VST + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,2),intent(out) :: HELI + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: CANGLE ! - real, dimension(im,jsta_2l:jend_2u) :: HTSFC, UST6, VST6, UST5, VST5, & + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: HTSFC, UST6, VST6, UST5, VST5, & UST1, VST1, USHR1, VSHR1, & USHR6, VSHR6, U1, V1, U2, V2, & HGT1, HGT2, UMEAN, VMEAN - real, dimension(im,jsta_2l:jend_2u) :: USHR05,VSHR05 + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: USHR05,VSHR05 ! REAL HTSFC(IM,JM) ! @@ -129,7 +131,7 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) ! REAL HGT1(IM,JM),HGT2(IM,JM),UMEAN(IM,JM),VMEAN(IM,JM) ! CRA - integer, dimension(im,jsta_2l:jend_2u) :: COUNT6, COUNT5, COUNT1, L1, L2 + integer, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: COUNT6, COUNT5, COUNT1, L1, L2 ! INTEGER COUNT6(IM,JM),COUNT5(IM,JM),COUNT1(IM,JM) ! CRA ! INTEGER L1(IM,JM),L2(IM,JM) @@ -148,7 +150,7 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND UST(I,J) = 0.0 VST(I,J) = 0.0 HELI(I,J,1) = 0.0 @@ -191,8 +193,8 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) IVE(J) = MOD(J,2) IVW(J) = IVE(J)-1 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE IF(gridtype == 'B')THEN @@ -202,8 +204,8 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) IVE(J)=1 IVW(J)=0 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE @@ -213,8 +215,8 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) IVE(J) = 0 IVW(J) = 0 enddo - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND END IF @@ -229,9 +231,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 976778bfb..942011340 100644 --- a/sorc/ncep_post.fd/CALHEL3.f +++ b/sorc/ncep_post.fd/CALHEL3.f @@ -41,6 +41,8 @@ !! AND CRITICAL ANGLE !! 21-03-15 E COLON - CALHEL2 MODIFIED TO COMPUTE EFFECTIVE !! RATHER THAN FIXED LAYER HELICITY +!! 21-09-02 Bo Cui - Decompose UPP in X direction + !! USAGE: CALHEL3(UST,VST,HELI) !! INPUT ARGUMENT LIST: !! LLOW - LOWER BOUND CAPE>=100 AND CINS>=-250 @@ -86,7 +88,8 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) use params_mod, only: g use lookup_mod, only: ITB,JTB,ITBQ,JTBQ use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, jsta_2l, jend_2u, & - lm, im, jm, me, spval + lm, im, jm, me, spval, & + ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -104,15 +107,15 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) ! ! DECLARE VARIABLES ! - integer,dimension(IM,jsta_2l:jend_2u),intent(in) :: LLOW, LUPP - REAL,dimension(IM,jsta_2l:jend_2u), intent(out) :: UST,VST - REAL,dimension(IM,jsta_2l:jend_2u),intent(out) :: HELI + integer,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: LLOW, LUPP + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: UST,VST + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(out) :: HELI ! - real, dimension(im,jsta_2l:jend_2u) :: HTSFC, UST6, VST6, UST5, VST5, & + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: HTSFC, UST6, VST6, UST5, VST5, & UST1, VST1, USHR1, VSHR1, & USHR6, VSHR6, U1, V1, U2, V2, & HGT1, HGT2, UMEAN, VMEAN - real, dimension(im,jsta_2l:jend_2u) :: USHR05,VSHR05,ELT,ELB + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: USHR05,VSHR05,ELT,ELB ! REAL HTSFC(IM,JM) ! @@ -125,7 +128,7 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) ! REAL HGT1(IM,JM),HGT2(IM,JM),UMEAN(IM,JM),VMEAN(IM,JM) ! CRA - integer, dimension(im,jsta_2l:jend_2u) :: COUNT6, COUNT5, COUNT1, L1, L2 + integer, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: COUNT6, COUNT5, COUNT1, L1, L2 ! INTEGER COUNT6(IM,JM),COUNT5(IM,JM),COUNT1(IM,JM) ! CRA ! INTEGER L1(IM,JM),L2(IM,JM) @@ -144,7 +147,7 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND UST(I,J) = 0.0 VST(I,J) = 0.0 HELI(I,J) = 0.0 @@ -185,8 +188,8 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) IVE(J) = MOD(J,2) IVW(J) = IVE(J)-1 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE IF(gridtype == 'B')THEN @@ -196,8 +199,8 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) IVE(J)=1 IVW(J)=0 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE @@ -207,8 +210,8 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) IVE(J) = 0 IVW(J) = 0 enddo - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND END IF @@ -223,9 +226,9 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) ! END DO ! !!$omp parallel do private(htsfc,ie,iw) - IF(gridtype /= 'A') CALL EXCH(FIS(1:IM,JSTA_2L:JEND_2U)) + IF(gridtype /= 'A') CALL EXCH(FIS(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)) DO L = 1,LM - IF(gridtype /= 'A') CALL EXCH(ZMID(1:IM,JSTA_2L:JEND_2U,L)) + IF(gridtype /= 'A') CALL EXCH(ZMID(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) DO J=JSTART,JSTOP DO I=ISTART,ISTOP IE = I+IVE(J) diff --git a/sorc/ncep_post.fd/CALLCL.f b/sorc/ncep_post.fd/CALLCL.f index 4b029b758..7652e6830 100644 --- a/sorc/ncep_post.fd/CALLCL.f +++ b/sorc/ncep_post.fd/CALLCL.f @@ -20,6 +20,7 @@ !! 02-04-24 MIKE BALDWIN - WRF VERSION !! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT !! 21-07-28 W Meng - Restriction compuatation from undefined grids +!! 21-09-02 Bo Cui - Decompose UPP in X direction !! !! USAGE: CALL CALLCL(P1D,T1D,Q1D,PLCL,ZLCL) !! INPUT ARGUMENT LIST: @@ -53,7 +54,8 @@ SUBROUTINE CALLCL(P1D,T1D,Q1D,PLCL,ZLCL) use vrbls2d, only: fis use masks, only: lmh use params_mod, only: eps, oneps, d01, h1m12, gi, d00 - use ctlblk_mod, only: jsta, jend, spval, jsta_m, jend_m, im + use ctlblk_mod, only: jsta, jend, spval, jsta_m, jend_m, im, & + ista, iend, ista_m, iend_m !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -62,9 +64,9 @@ SUBROUTINE CALLCL(P1D,T1D,Q1D,PLCL,ZLCL) ! ! DECLARE VARIABLES. ! - REAL,dimension(IM,jsta:jend), intent(in) :: P1D,T1D,Q1D - REAL,dimension(IM,jsta:jend), intent(inout) :: PLCL,ZLCL - REAL TLCL(IM,jsta:jend) + REAL,dimension(ista:iend,jsta:jend), intent(in) :: P1D,T1D,Q1D + REAL,dimension(ista:iend,jsta:jend), intent(inout) :: PLCL,ZLCL + REAL TLCL(ista:iend,jsta:jend) integer I,J,L,LLMH real DLPLCL,ZSFC,DZ,DALP,ALPLCL,RMX,EVP,ARG,RKAPA ! @@ -75,7 +77,7 @@ SUBROUTINE CALLCL(P1D,T1D,Q1D,PLCL,ZLCL) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PLCL(I,J) = SPVAL TLCL(I,J) = SPVAL ZLCL(I,J) = SPVAL @@ -87,8 +89,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) 0.) then ! count from north to south - 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 enddo else ! count from south to north - 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 @@ -154,20 +155,20 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) end if elseif (j == JM) then if(gdlat(1,j) < 0.) then ! count from north to south - 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) enddo else ! count from south to north - 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) enddo end if else - do i=1,im + do i=ista,iend wrk3(i,j) = 1.0 / ((GDLAT(I,J-1)-GDLAT(I,J+1))*DTR) !1/dphi enddo endif @@ -183,7 +184,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) 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 + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) ii = i + imb2 @@ -197,7 +198,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) enddo ELSE !pole point, compute at j=2 jj = 2 - DO I=1,IM + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. & @@ -210,7 +211,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) ENDIF else IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) ii = i + imb2 @@ -224,7 +225,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) enddo ELSE !pole point, compute at j=2 jj = 2 - DO I=1,IM + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. & @@ -239,7 +240,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) 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 + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) ii = i + imb2 @@ -253,7 +254,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) enddo ELSE !pole point,compute at jm-1 jj = jm-1 - DO I=1,IM + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. & @@ -266,7 +267,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) ENDIF else IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) ii = i + imb2 @@ -280,7 +281,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) enddo ELSE !pole point,compute at jm-1 jj = jm-1 - DO I=1,IM + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. & @@ -293,7 +294,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) ENDIF endif ELSE - DO I=1,IM + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. & @@ -307,11 +308,11 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) ! 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 + do i=ista,iend tx1(i) = absv(i,j) enddo do nn=1,npass - do i=1,im + do i=ista,iend tx2(i+1) = tx1(i) enddo tx2(1) = tx2(im+1) @@ -320,7 +321,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) tx1(i-1) = 0.25 * (tx2(i-1) + tx2(i+1)) + 0.5*tx2(i) enddo enddo - do i=1,im + do i=ista,iend absv(i,j) = tx1(i) enddo endif @@ -335,7 +336,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) ELSE !(MODELNAME == 'GFS' .or. global) IF (GRIDTYPE == 'B')THEN - CALL EXCH_F(VWND) + CALL EXCH(VWND) ENDIF CALL DVDXDUDY(UWND,VWND) @@ -345,7 +346,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) 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 IF(VWND(I+1,J) 0.) then ! count from north to south - 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 enddo else ! count from south to north - 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 @@ -527,20 +529,20 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) end if elseif (j == JM) then if(gdlat(1,j) < 0.) then ! count from north to south - 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) enddo else ! count from south to north - 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) enddo end if else - do i=1,im + do i=ista,iend wrk3(i,j) = 1.0 / ((GDLAT(I,J-1)-GDLAT(I,J+1))*DTR) !1/dphi enddo endif @@ -549,19 +551,19 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) do l=1,lm !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND DIV(I,J,l) = SPVAL ENDDO ENDDO - CALL EXCH_F(VWND(1,jsta_2l,l)) + CALL EXCH(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 + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) ii = i + imb2 @@ -573,7 +575,7 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) !-- ELSE !North pole point, compute at j=2 jj = 2 - do i=1,im + 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) & @@ -584,7 +586,7 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) ENDIF else IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) ii = i + imb2 @@ -596,7 +598,7 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) !-- ELSE !North pole point, compute at j=2 jj = 2 - do i=1,im + 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) & @@ -608,7 +610,7 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) 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 + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) ii = i + imb2 @@ -620,7 +622,7 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) !-- ELSE !South pole point,compute at jm-1 jj = jm-1 - do i=1,im + 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) & @@ -631,7 +633,7 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) ENDIF else IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) ii = i + imb2 @@ -643,7 +645,7 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) !-- ELSE !South pole point,compute at jm-1 jj = jm-1 - do i=1,im + 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) & @@ -654,7 +656,7 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) ENDIF endif ELSE - DO I=1,IM + 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) & @@ -721,15 +723,17 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) 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 + 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(im,jsta_2l:jend_2u), intent(in) :: PS - REAL, dimension(im,jsta_2l:jend_2u), intent(inout) :: PSX,PSY + 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(:) @@ -744,7 +748,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) !sk06162016 DO J=JSTA_2L,JEND_2U !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PSX(I,J) = SPVAL PSY(I,J) = SPVAL !sk PSX(I,J) = D00 @@ -752,18 +756,18 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) ENDDO ENDDO - CALL EXCH_F(PS) + CALL EXCH(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 (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=1,im + do i=ista,iend ie(i) = i+1 iw(i) = i-1 enddo @@ -773,7 +777,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) !$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) @@ -796,13 +800,13 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) DO J=JSTA,JEND if (j == 1) then if(gdlat(1,j) > 0.) then ! count from north to south - 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 enddo else ! count from south to north - 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 @@ -810,20 +814,20 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) end if elseif (j == JM) then if(gdlat(1,j) < 0.) then ! count from north to south - 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) enddo else ! count from south to north - 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) enddo end if else - do i=1,im + do i=ista,iend wrk3(i,j) = 1.0 / ((GDLAT(I,J-1)-GDLAT(I,J+1))*DTR) !1/dphi enddo endif @@ -834,7 +838,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) 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 + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) ii = i + imb2 @@ -844,7 +848,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) enddo ELSE !North pole point, compute at j=2 jj = 2 - DO I=1,IM + 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) @@ -853,7 +857,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) ENDIF else IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) ii = i + imb2 @@ -863,7 +867,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) enddo ELSE !North pole point, compute at j=2 jj = 2 - DO I=1,IM + 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) @@ -874,7 +878,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) 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 + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) ii = i + imb2 @@ -884,7 +888,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) enddo ELSE !South pole point,compute at jm-1 jj = jm-1 - DO I=1,IM + 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) @@ -893,7 +897,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) ENDIF else IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) ii = i + imb2 @@ -903,7 +907,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) enddo ELSE !South pole point,compute at jm-1 jj = jm-1 - DO I=1,IM + 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) @@ -912,7 +916,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) ENDIF endif ELSE - DO I=1,IM + 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) From 40ed93da812c96c6de522a4fbdbe55fba63cebbf Mon Sep 17 00:00:00 2001 From: wx22mj Date: Tue, 26 Oct 2021 17:23:08 +0000 Subject: [PATCH 39/77] 20211026 Jesse Meng commit progress in 2D DECOMPOSITION --- sorc/ncep_post.fd/MDL2THANDPV.f | 214 +++++++++++++++++++------------- sorc/ncep_post.fd/UPP_MATH.f | 74 +++++------ 2 files changed, 165 insertions(+), 123 deletions(-) diff --git a/sorc/ncep_post.fd/MDL2THANDPV.f b/sorc/ncep_post.fd/MDL2THANDPV.f index bc5d6efef..5950e3959 100644 --- a/sorc/ncep_post.fd/MDL2THANDPV.f +++ b/sorc/ncep_post.fd/MDL2THANDPV.f @@ -48,8 +48,9 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) use masks, only: gdlat, gdlon, dx, dy use physcons_post, only: con_eps, con_epsm1 use params_mod, only: dtr, small, erad, d608, rhmin - use CTLBLK_mod, only: spval, lm, jsta_2l, jend_2u, jsta_2l, grib, cfld, datapd, fld_info,& - im, jm, jsta, jend, jsta_m, jend_m, modelname, global,gdsdegr,me + use CTLBLK_mod, only: spval, lm, jsta_2l, jend_2u, grib, cfld, datapd, fld_info,& + im, jm, jsta, jend, jsta_m, jend_m, modelname, global,gdsdegr,me,& + ista, iend, ista_m, iend_m, ista_2l, iend_2u use RQSTFLD_mod, only: iget, lvls, id, iavblfld, lvlsxml use gridspec_mod, only: gridtype,dyval use upp_physics, only: FPVSNEW @@ -61,7 +62,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ! integer,intent(in) :: kth, kpv real, intent(in) :: th(kth), pv(kpv) - real, dimension(im,jsta:jend) :: grid1, grid2 + real, dimension(ista:iend,jsta:jend) :: grid1, grid2 real, dimension(kpv) :: pvpt, pvpb LOGICAL IOOMG,IOALL @@ -72,9 +73,9 @@ 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, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), wrk4(:,:), cosl(:,:) real, allocatable :: tuv(:,:,:),pmiduv(:,:,:) @@ -88,7 +89,9 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) !****************************************************************************** ! ! START MDL2TH. -! +! + if(me==0) write(0,*) 'MDL2THANDPV starts' +! ! SET TOTAL NUMBER OF POINTS ON OUTPUT GRID. ! !--------------------------------------------------------------- @@ -119,7 +122,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) do k=1,kth !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend UTH(i,j,k) = SPVAL VTH(i,j,k) = SPVAL HMTH(i,j,k) = SPVAL @@ -134,7 +137,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) do k=1,kpv !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend UPV(i,j,k) = SPVAL VPV(i,j,k) = SPVAL HPV(i,j,k) = SPVAL @@ -151,21 +154,37 @@ 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)) + + if(me==0) then + write(0,*) 'me,ista_2l,ista,iend,iend_2u' + write(0,*) me,ista_2l,ista,iend,iend_2u + write(0,*) 'me,jsta_2l,jsta,jend,jend_2u' + write(0,*) me,jsta_2l,jsta,jend,jend_2u + write(0,*) 'me,gdlon(ista_2l,jsta),gdlon(ista-1,jsta),gdlon(ista,jsta),gdlon(iend,jsta),gdlon(iend+1,jsta),gdlon(iend_2u,jsta)' + write(0,*) me,gdlon(ista_2l,jsta),gdlon(ista-1,jsta),gdlon(ista,jsta),gdlon(iend,jsta),gdlon(iend+1,jsta),gdlon(iend_2u,jsta) + write(0,*) 'me,vh(ista_2l,jsta,1),vh(ista-1,jsta,1),vh(ista,jsta,1),vh(iend,jsta,1),vh(iend+1,jsta,1),vh(iend_2u,jsta,1)' + write(0,*) me,vh(ista_2l,jsta,1),vh(ista-1,jsta,1),vh(ista,jsta,1),vh(iend,jsta,1),vh(iend+1,jsta,1),vh(iend_2u,jsta,1) + ! write(0,*) 'me,gdlat(ista,jsta_2l),gdlat(ista,jsta),gdlat(iend,jend),gdlat(iend,jend_2u)' + ! write(0,*) me,gdlat(ista,jsta_2l),gdlat(ista,jsta),gdlat(iend,jend),gdlat(iend,jend_2u) + endif ! 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 (wrk4(ista:iend,jsta:jend)) imb2 = im /2 + !imb2=0 !JESSE to be discussed for x decomposition eradi = 1.0 / erad !! IF(MODELNAME == 'GFS' .or. global) THEN @@ -175,12 +194,15 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ie(i) = i + 1 iw(i) = i - 1 enddo +!JESSE 2D DECOMPOSITION iw(1) = im ie(im) = 1 + !iw(1) = 1 + !ie(im) = im ! !$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) @@ -203,13 +225,13 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) !$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 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 @@ -217,7 +239,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) else !print *,' j=',j,' GDLATJm1=',gdlat(:,j-1) !print *,' j=',j,' GDLATJp1=',gdlat(:,j+1) - do i=1,im + do i=ISTA,IEND tem = GDLAT(I,J-1) - GDLAT(I,J+1) if (abs(tem) > small) then wrk3(i,j) = 1.0 / (tem*DTR) !1/dphi @@ -232,7 +254,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) else !!global? !$omp parallel do private(i,j) DO J=JSTA_m,Jend_m - DO I=2,im-1 + DO I=ISTA_M,IEND_M wrk2(i,j) = 0.5 / DX(I,J) wrk3(i,j) = 0.5 / DY(I,J) END DO @@ -241,11 +263,11 @@ 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 @@ -254,7 +276,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(MODELNAME == 'GFS' .or. global) THEN !!$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 @@ -410,7 +432,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 @@ -486,14 +508,15 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ENDIF !regional models and A-grid end here !----------------------------------------------------------------- ELSE IF (GRIDTYPE == 'B')THEN - allocate(DVDXL(1:im,jsta_m:jend_m,lm)) - allocate(DUDYL(1:im,jsta_m:jend_m,lm)) - allocate(UAVGL(1:im,jsta_m:jend_m,lm)) + allocate(DVDXL(ista_m:iend_m,jsta_m:jend_m,lm)) + allocate(DUDYL(ista_m:iend_m,jsta_m:jend_m,lm)) + allocate(UAVGL(ista_m:iend_m,jsta_m:jend_m,lm)) DO L=1,LM - CALL EXCH(VH(1:IM,JSTA_2L:JEND_2U,L)) + CALL EXCH(VH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) + CALL EXCH(UH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) CALL DVDXDUDY(UH(:,:,L),VH(:,:,L)) DO J=JSTA_m,Jend_m - DO I=2,im-1 + DO I=ISTA_M,IEND_M DVDXL(I,J,L) = DDVDX(I,J) DUDYL(I,J,L) = DDUDY(I,J) UAVGL(I,J,L) = UUAVG(I,J) @@ -503,7 +526,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) DO J=JSTA_m,Jend_m JMT2=JM/2+1 TPHI=(J-JMT2)*(DYVAL/gdsdegr)*DTR - DO I=2,im-1 + DO I=ISTA_M,IEND_M ip1 = i + 1 im1 = i - 1 DO L=1,LM @@ -580,7 +603,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) TPHI = (J-JMT2)*(DYVAL/gdsdegr)*DTR IHW= - MOD(J,2) IHE = IHW + 1 - DO I=2,im-1 + DO I=ISTA_M,IEND_M ip1 = i + 1 im1 = i - 1 DO L=1,LM @@ -673,7 +696,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(LVLS(LP,IGET(332)) > 0 .OR. LVLS(LP,IGET(333)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = UTH(I,J,LP) GRID2(I,J) = VTH(I,J,LP) ENDDO @@ -682,21 +705,23 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(332)) fld_info(cfld)%lvl = LVLSXML(lp,IGET(332)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(333)) fld_info(cfld)%lvl = LVLSXML(lp,IGET(333)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -731,7 +756,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ! END IF !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TTH(I,J,LP) ENDDO ENDDO @@ -739,11 +764,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(334)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(334)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -754,6 +780,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ! IF(IGET(335) > 0) THEN IF(LVLS(LP,IGET(335)) > 0)THEN +!JESSE TBD 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= ' & @@ -761,7 +788,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ,pvth(10,10,lp),pvth(im/2,10,lp),SPVAL,grib,LP !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(PVTH(I,J,LP) /= SPVAL)THEN GRID1(I,J) = PVTH(I,J,LP)*1.0E-6 ELSE @@ -773,11 +800,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(335)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(335)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -790,7 +818,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(LVLS(LP,IGET(353)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = HMTH(I,J,LP) ENDDO ENDDO @@ -798,11 +826,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(353)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(353)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -815,7 +844,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(LVLS(LP,IGET(351)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SIGMATH(I,J,LP) ENDDO ENDDO @@ -823,11 +852,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(351)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(351)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -840,7 +870,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(LVLS(LP,IGET(352)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(RHTH(I,J,LP) /= SPVAL) THEN GRID1(I,J) = 100.0 * MIN(1.,MAX(RHmin,RHTH(I,J,LP))) ELSE @@ -852,11 +882,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(352)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(352)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -869,7 +900,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(LVLS(LP,IGET(378)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = OTH(I,J,LP) ENDDO ENDDO @@ -877,11 +908,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 @@ -899,7 +931,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ,SPVAL,VPV(1:IM,JSTA:JEND,LP)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = UPV(I,J,LP) GRID2(I,J) = VPV(I,J,LP) ENDDO @@ -908,21 +940,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 @@ -939,7 +973,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ,SPVAL,TPV(1:IM,JSTA:JEND,LP)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TPV(I,J,LP) ENDDO ENDDO @@ -947,11 +981,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 @@ -967,7 +1002,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ,SPVAL,HPV(1:IM,JSTA:JEND,LP)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = HPV(I,J,LP) ENDDO ENDDO @@ -975,11 +1010,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 @@ -995,7 +1031,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ,SPVAL,PPV(1:IM,JSTA:JEND,LP)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PPV(I,J,LP) ENDDO ENDDO @@ -1003,11 +1039,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 @@ -1023,7 +1060,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ,SPVAL,SPV(1:IM,JSTA:JEND,LP)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SPV(I,J,LP) ENDDO ENDDO @@ -1031,11 +1068,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 @@ -1049,7 +1087,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) DUM1D14,wrk1, wrk2, wrk3, wrk4, cosl) 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/UPP_MATH.f b/sorc/ncep_post.fd/UPP_MATH.f index 2b1ad4a75..a05a35566 100644 --- a/sorc/ncep_post.fd/UPP_MATH.f +++ b/sorc/ncep_post.fd/UPP_MATH.f @@ -19,7 +19,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 @@ -43,7 +44,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 !-- @@ -54,7 +55,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 + DO I=ISTA,IEND outgrid(i,jm) = outgrid(i,jm-1) END DO END IF ELSE IF(GRIDTYPE == 'C')THEN DO J=JSTA,JEND - DO I=1,IM-1 + DO I=ISTA,IEND_M outgrid(i,j)=(ingrid(i,j)+ingrid(i+1,j))/2.0 end do end do @@ -172,24 +173,25 @@ 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)) 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 @@ -198,14 +200,14 @@ subroutine H2V(ingrid,outgrid) ELSE IF(GRIDTYPE == 'B')THEN call exch(ingrid(1,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)) DO J=JSTA,JEND_M - DO I=1,IM + DO I=ISTA,IEND outgrid(i,j)=(ingrid(i,j)+ingrid(i,j+1))/2.0 end do end do @@ -218,24 +220,25 @@ 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)) 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 @@ -244,13 +247,13 @@ subroutine U2H(ingrid,outgrid) ELSE IF(GRIDTYPE == 'B')THEN call exch(ingrid(1,jsta_2l)) DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M outgrid(i,j)=(ingrid(i-1,j-1)+ingrid(i,j-1)+ingrid(i-1,j)+ingrid(i,j))/4.0 end do end do ELSE IF(GRIDTYPE == 'C')THEN DO J=JSTA,JEND - DO I=2,IM + DO I=ISTA_M,IEND outgrid(i,j)=(ingrid(i-1,j)+ingrid(i,j))/2.0 end do end do @@ -263,24 +266,25 @@ 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)) 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 @@ -289,14 +293,14 @@ subroutine V2H(ingrid,outgrid) ELSE IF(GRIDTYPE == 'B')THEN call exch(ingrid(1,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)) 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 From 9306634c1bc53238b1dc82d4156a64aa78e85112 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Tue, 26 Oct 2021 19:40:27 +0000 Subject: [PATCH 40/77] 20211026 Jesse Meng fix INITPOST_GFS_NETCDF_PARA.f for 2D DECOMPOSITION --- sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f | 29 ++++++++++---------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f index 67f071f8b..844d4b36d 100644 --- a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f +++ b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f @@ -10,6 +10,7 @@ !! REVISION HISTORY !! 2020-02-04 W Meng start from INITPOST_GFS_NETCDF.f !! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) +!! 2021-10-26 J Meng 2D DECOMPOSITION !! !! USAGE: CALL INITPOST_GFS_NETCDF_PARA !! INPUT ARGUMENT LIST: @@ -926,7 +927,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) VarName='land' call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,sm) - if(debugprint)print*,'sample ',VarName,' =',sm(im/2,(jsta+jend)/2) + if(debugprint)print*,'sample ',VarName,' =',sm((ista+iend)/2,(jsta+jend)/2) !$omp parallel do private(i,j) do j=jsta,jend @@ -1277,7 +1278,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! land fraction VarName='lfrac' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,landfrac) ! GFS probably does not use sigt4, set it to sig*t^4 @@ -2143,48 +2144,48 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! accumulated evaporation of intercepted water VarName='ecan_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,tecan) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) tecan(i,j) = spval enddo enddo ! accumulated plant transpiration VarName='etran_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,tetran) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) tetran(i,j) = spval enddo enddo ! accumulated soil surface evaporation VarName='edir_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,tedir) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) tedir(i,j) = spval enddo enddo ! total water storage in aquifer VarName='wa_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,twa) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) twa(i,j) = spval enddo enddo @@ -2359,24 +2360,24 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! retrieve AVERAGED PRECIP ADVECTED HEAT FLUX VarName='pah_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,paha) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) paha(i,j) = spval enddo enddo ! retrieve nstantaneous PRECIP ADVECTED HEAT FLUX VarName='pahi' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,pahi) ! mask water areas !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend if (sm(i,j) /= 0.0) pahi(i,j) = spval enddo enddo From 6308e3c19a073230a670c4b45b0181b06d029697 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Tue, 26 Oct 2021 20:34:12 +0000 Subject: [PATCH 41/77] 20211026 Jesse Meng update SURFCE.f for 2D DECOMPOSITION --- sorc/ncep_post.fd/CLMAX.f | 13 +++++----- sorc/ncep_post.fd/SURFCE.f | 52 +++++++++++++++++++++----------------- 2 files changed, 36 insertions(+), 29 deletions(-) diff --git a/sorc/ncep_post.fd/CLMAX.f b/sorc/ncep_post.fd/CLMAX.f index dcc72512b..72115c52b 100644 --- a/sorc/ncep_post.fd/CLMAX.f +++ b/sorc/ncep_post.fd/CLMAX.f @@ -8,6 +8,7 @@ SUBROUTINE CLMAX(EL0,SQZ,SQ,RQ2L,RQ2H) ! 01-10-22 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT ! 02-06-19 MIKE BALDWIN - WRF VERSION ! 21-07-26 W Meng - Restrict computation from undefined grids +! 21-10-26 J MENG - 2D DECOMPOSITION ! ! INPUT: ! ------ @@ -42,7 +43,7 @@ SUBROUTINE CLMAX(EL0,SQZ,SQ,RQ2L,RQ2H) ! use vrbls2d, only: use masks, only: lmh, sm use params_mod, only: EPSQ2 - use ctlblk_mod, only: jsta, jend, lm, im, spval + use ctlblk_mod, only: jsta, jend, lm, im, spval, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -56,8 +57,8 @@ SUBROUTINE CLMAX(EL0,SQZ,SQ,RQ2L,RQ2H) ! ! ------------------------------------------------------------------ ! - real,dimension(IM,jsta:jend),intent(inout) :: SQZ,SQ,RQ2L,RQ2H,EL0 - real,dimension(IM,jsta:jend) :: HGT + real,dimension(ista:iend,jsta:jend),intent(inout) :: SQZ,SQ,RQ2L,RQ2H,EL0 + real,dimension(ista:iend,jsta:jend) :: HGT !jw integer I,J,L real dp, RQ2m @@ -66,7 +67,7 @@ SUBROUTINE CLMAX(EL0,SQZ,SQ,RQ2L,RQ2H) ! !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND SQZ(I,J) = 0.0 SQ(I,J) = 0.0 RQ2H(I,J) = 0.0 @@ -76,7 +77,7 @@ SUBROUTINE CLMAX(EL0,SQZ,SQ,RQ2L,RQ2H) ! DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(Q2(I,J,L) <= EPSQ2) THEN RQ2L(I,J) = 0.0 ELSE @@ -121,7 +122,7 @@ SUBROUTINE CLMAX(EL0,SQZ,SQ,RQ2L,RQ2H) !*** !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(HGT(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) = TECAN(I,J) ENDDO ENDDO @@ -1334,11 +1337,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 @@ -1347,7 +1351,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 @@ -1375,11 +1379,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 @@ -1388,7 +1393,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 @@ -1416,11 +1421,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 @@ -1434,7 +1440,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 @@ -1469,7 +1475,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 ! From b0c9102c7ce63e84529641ca0918b3d1371bd09e Mon Sep 17 00:00:00 2001 From: wx22mj Date: Wed, 3 Nov 2021 13:27:10 +0000 Subject: [PATCH 42/77] 20211103 Jesse Meng commit progress of 2D DECOMPOSITION --- sorc/ncep_post.fd/CALUPDHEL.f | 16 ++++--- sorc/ncep_post.fd/CALVESSEL.f | 14 +++--- sorc/ncep_post.fd/CALVIS.f | 10 +++-- sorc/ncep_post.fd/CALVIS_GSD.f | 11 +++-- sorc/ncep_post.fd/CALVOR.f | 66 ++++++++++++++++------------- sorc/ncep_post.fd/CALWXT.f | 34 ++++++++------- sorc/ncep_post.fd/CALWXT_BOURG.f | 18 ++++---- sorc/ncep_post.fd/CALWXT_DOMINANT.f | 18 +++++--- sorc/ncep_post.fd/CALWXT_EXPLICIT.f | 15 ++++--- sorc/ncep_post.fd/CALWXT_RAMER.f | 26 ++++++------ sorc/ncep_post.fd/CALWXT_REVISED.f | 27 ++++++------ sorc/ncep_post.fd/MDL2THANDPV.f | 1 + sorc/ncep_post.fd/PROCESS.f | 14 ++++++ sorc/ncep_post.fd/SURFCE.f | 6 +-- sorc/ncep_post.fd/UPP_MATH.f | 24 +++++------ ush/gfs_nceppost.sh | 2 +- 16 files changed, 173 insertions(+), 129 deletions(-) diff --git a/sorc/ncep_post.fd/CALUPDHEL.f b/sorc/ncep_post.fd/CALUPDHEL.f index 11fbc98b2..65bf0fa50 100644 --- a/sorc/ncep_post.fd/CALUPDHEL.f +++ b/sorc/ncep_post.fd/CALUPDHEL.f @@ -11,6 +11,7 @@ !! 11-01-11 M Pyle - converted to F90 for unified post !! 11-04-05 H Chuang - added B grid option !! 20-11-06 J Meng - USE UPP_MATH MODULE +!! 21-10-31 J Meng - 2D DECOMPOSITION !! !! USAGE: CALL CALUPDHEL(UPDHEL) !! @@ -42,7 +43,8 @@ SUBROUTINE CALUPDHEL(UPDHEL) use masks, only: lmh, dx, dy use params_mod, only: d00 use ctlblk_mod, only: lm, jsta_2l, jend_2u, jsta_m, jend_m, & - global, spval, im, jm + global, spval, im, jm, & + ista_2l, iend_2u, ista_m, iend_m use gridspec_mod, only: gridtype use upp_math, only: DVDXDUDY, DDVDX, DDUDY @@ -54,7 +56,7 @@ SUBROUTINE CALUPDHEL(UPDHEL) REAL, PARAMETER:: HLOWER=2000., HUPPER=5000. REAL ZMIDLOC real :: r2dx, r2dy, dz, dcdx, dudy, dvdx - REAL :: HTSFC(IM,jsta_2l:jend_2u),UPDHEL(IM,jsta_2l:jend_2u) + REAL :: HTSFC(ista_2l:iend_2u,jsta_2l:jend_2u),UPDHEL(ista_2l:iend_2u,jsta_2l:jend_2u) integer :: l, j, i INTEGER, dimension(jm) :: IHE,IHW ! INTEGER DXVAL,DYVAL,CENLAT,CENLON,TRUELAT1,TRUELAT2 @@ -67,16 +69,16 @@ SUBROUTINE CALUPDHEL(UPDHEL) ! maxval(WH(:,:,20)) DO L=1,LM - CALL EXCH(UH(1,jsta_2l,L)) + CALL EXCH(UH(ista_2l,jsta_2l,L)) END DO IF (GRIDTYPE == 'B')THEN DO L=1,LM - CALL EXCH(VH(1,jsta_2l,L)) + CALL EXCH(VH(ista_2l,jsta_2l,L)) END DO END IF !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U UPDHEL(I,J) = D00 ENDDO ENDDO @@ -93,13 +95,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 R2DX = 1./(2.*DX(I,J)) R2DY = 1./(2.*DY(I,J)) 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) 0.) then ! count from north to south + if(gdlat(ista,j) > 0.) then ! count from north to south do i=ista,iend ii = i + imb2 if (ii > im) ii = ii - im @@ -154,7 +156,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) enddo end if elseif (j == JM) then - if(gdlat(1,j) < 0.) then ! count from north to south + if(gdlat(ista,j) < 0.) then ! count from north to south do i=ista,iend ii = i + imb2 if (ii > im) ii = ii - im @@ -182,8 +184,8 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) ! 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 + 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) @@ -210,7 +212,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) enddo ENDIF else - IF(cosl(1,j) >= SMALL) THEN !not a pole point + IF(cosl(ista,j) >= SMALL) THEN !not a pole point DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) @@ -238,8 +240,8 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) 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 + 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) @@ -266,7 +268,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) enddo ENDIF else - IF(cosl(1,j) >= SMALL) THEN !not a pole point + IF(cosl(ista,j) >= SMALL) THEN !not a pole point DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) @@ -337,6 +339,7 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) IF (GRIDTYPE == 'B')THEN CALL EXCH(VWND) + CALL EXCH(UWND) ENDIF CALL DVDXDUDY(UWND,VWND) @@ -474,7 +477,8 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) ! ! LOOP TO COMPUTE DIVERGENCE FROM WINDS. ! - CALL EXCH(GDLAT(1,JSTA_2L)) + 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)) @@ -514,7 +518,7 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) !$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 + if(gdlat(ista,j) > 0.) then ! count from north to south do i=ista,iend ii = i + imb2 if (ii > im) ii = ii - im @@ -528,7 +532,7 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) enddo end if elseif (j == JM) then - if(gdlat(1,j) < 0.) then ! count from north to south + if(gdlat(ista,j) < 0.) then ! count from north to south do i=ista,iend ii = i + imb2 if (ii > im) ii = ii - im @@ -556,13 +560,14 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) ENDDO ENDDO - CALL EXCH(VWND(1,jsta_2l,l)) + CALL EXCH(VWND(ista_2l,jsta_2l,l)) + CALL EXCH(UWND(ista_2l,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 + 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) @@ -585,7 +590,7 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) !-- ENDIF else - IF(cosl(1,j) >= SMALL) THEN !not a pole point + IF(cosl(ista,j) >= SMALL) THEN !not a pole point DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) @@ -608,8 +613,8 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) 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 + 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) @@ -632,7 +637,7 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) enddo ENDIF else - IF(cosl(1,j) >= SMALL) THEN !not a pole point + IF(cosl(ista,j) >= SMALL) THEN !not a pole point DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) @@ -674,7 +679,7 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) ! 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) + 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 @@ -759,7 +764,8 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) CALL EXCH(PS) ! IF (MODELNAME == 'GFS' .or. global) THEN - CALL EXCH(GDLAT(1,JSTA_2L)) + 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)) @@ -799,7 +805,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) !$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 + if(gdlat(ista,j) > 0.) then ! count from north to south do i=ista,iend ii = i + imb2 if (ii > im) ii = ii - im @@ -813,7 +819,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) enddo end if elseif (j == JM) then - if(gdlat(1,j) < 0.) then ! count from north to south + if(gdlat(ista,j) < 0.) then ! count from north to south do i=ista,iend ii = i + imb2 if (ii > im) ii = ii - im @@ -836,8 +842,8 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) !$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 + 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) @@ -856,7 +862,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) enddo ENDIF else - IF(cosl(1,j) >= SMALL) THEN !not a pole point + IF(cosl(ista,j) >= SMALL) THEN !not a pole point DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) @@ -876,8 +882,8 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) 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 + 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) @@ -896,7 +902,7 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) enddo ENDIF else - IF(cosl(1,j) >= SMALL) THEN !not a pole point + IF(cosl(ista,j) >= SMALL) THEN !not a pole point DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) diff --git a/sorc/ncep_post.fd/CALWXT.f b/sorc/ncep_post.fd/CALWXT.f index a50a6065c..48aac1332 100644 --- a/sorc/ncep_post.fd/CALWXT.f +++ b/sorc/ncep_post.fd/CALWXT.f @@ -10,6 +10,7 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) ! 05-07-07 BINBIN ZHOU - ADD PREC FOR RSM ! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT ! 21-07-26 Wen Meng - Restrict computation from undefined grids +! 21-10-31 JESSE MENG - 2D DECOMPOSITION ! ! ! ROUTINE TO COMPUTE PRECIPITATION TYPE USING A DECISION TREE @@ -22,19 +23,20 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) ! use params_mod, only: h1m12, d00, d608, h1, rog use ctlblk_mod, only: jsta, jend, spval, modelname,pthresh, im, & - jsta_2l, jend_2u, lm, lp1 + jsta_2l, jend_2u, lm, lp1, & + ista, iend, ista_2l, iend_2u !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! INPUT: ! T,Q,PMID,HTM,LMH,PREC,ZINT ! - real,dimension(IM,jsta_2l:jend_2u),intent(in) :: LMH - real,dimension(IM,jsta_2l:jend_2u,LM),intent(in) :: T,Q,PMID,HTM - real,dimension(IM,jsta_2l:jend_2u,LP1),intent(in) :: ZINT,PINT - integer,DIMENSION(IM,jsta:jend),intent(inout) :: IWX - real,dimension(IM,jsta_2l:jend_2u),intent(inout) :: PREC - real,DIMENSION(IM,jsta:jend),intent(inout) :: ZWET + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: LMH + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,LM),intent(in) :: T,Q,PMID,HTM + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,LP1),intent(in) :: ZINT,PINT + integer,DIMENSION(ista:iend,jsta:jend),intent(inout) :: IWX + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(inout) :: PREC + real,DIMENSION(ista:iend,jsta:jend),intent(inout) :: ZWET ! OUTPUT: @@ -49,8 +51,8 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) ! INTERNAL: ! REAL, ALLOCATABLE :: TWET(:,:,:) - integer,DIMENSION(IM,jsta:jend) :: KARR,LICEE - real, DIMENSION(IM,jsta:jend) :: TCOLD,TWARM + integer,DIMENSION(ista:iend,jsta:jend) :: KARR,LICEE + real, DIMENSION(ista:iend,jsta:jend) :: TCOLD,TWARM logical :: jcontinue=.true. ! SUBROUTINES CALLED: @@ -69,12 +71,12 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) real PSFCK,TDCHK,A,TDKL,TDPRE,TLMHK,TWRMK,AREAS8,AREAP4, & SURFW,SURFC,DZKL,AREA1,PINTK1,PINTK2,PM150,PKL,TKL,QKL - ALLOCATE ( TWET(IM,JSTA_2L:JEND_2U,LM) ) + ALLOCATE ( TWET(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM) ) ! !!$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IWX(I,J) = 0 ZWET(I,J) = SPVAL ! if (I == 324 .and. J == 390) then @@ -88,7 +90,7 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) IF(MODELNAME=='RSM') THEN !add by Binbin because of different unit DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PREC(I,J) = PREC(I,J)*3*3600.0 ENDDO ENDDO @@ -98,7 +100,7 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) ! !!$omp parallel do private(a,lmhk,pkl,psfck,qkl,tdchk,tdkl,tdpre,tkl) DO 800 J=JSTA,JEND - DO 800 I=1,IM + DO 800 I=ISTA,IEND LMHK=NINT(LMH(I,J)) ! ! SKIP THIS POINT IF NO PRECIP THIS TIME STEP @@ -155,7 +157,7 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) ! LOWEST LAYER T ! DO 850 J=JSTA,JEND - DO 850 I=1,IM + DO 850 I=ISTA,IEND KARR(I,J)=0 IF (PREC(I,J)<=PTHRESH) cycle LMHK=NINT(LMH(I,J)) @@ -195,7 +197,7 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) ! & lmhk,pintk1,pintk2,pm150,psfck,surfc,surfw, & ! & tlmhk,twrmk) DO 1900 J=JSTA,JEND - DO 1900 I=1,IM + DO 1900 I=ISTA,IEND ! IF (I == 324 .AND. J == 390) THEN ! LMHK=NINT(LMH(I,J)) ! DO L=LMHK,1,-1 @@ -318,7 +320,7 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) IF(MODELNAME == 'RSM') THEN !add by Binbin, change back !!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PREC(I,J) = PREC(I,J)/(3*3600.0) ENDDO ENDDO diff --git a/sorc/ncep_post.fd/CALWXT_BOURG.f b/sorc/ncep_post.fd/CALWXT_BOURG.f index aef3300f1..230b34de5 100644 --- a/sorc/ncep_post.fd/CALWXT_BOURG.f +++ b/sorc/ncep_post.fd/CALWXT_BOURG.f @@ -13,6 +13,7 @@ !! 2005-08-24 G Manikin added to wrf post !! 2007-06-19 M Iredell mersenne twister, best practices !! 2015-00-00 S Moorthi changed random number call and optimization and cleanup +!! 2021-10-31 J Meng 2D DECOMPOSITION !! !! Usage: call calwxt_bourg(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & !! & iseed,g,pthresh, & @@ -64,21 +65,22 @@ !! !! - subroutine calwxt_bourg_post(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & + subroutine calwxt_bourg_post(im,ista_2l,iend_2u,ista,iend,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & & iseed,g,pthresh, & & t,q,pmid,pint,lmh,prec,zint,ptype,me) implicit none ! ! input: - integer,intent(in):: im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1,iseed,me + integer,intent(in):: im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1,iseed,me,& + ista_2l,iend_2u,ista,iend real,intent(in):: g,pthresh - real,intent(in), dimension(im,jsta_2l:jend_2u,lm) :: t, q, pmid - real,intent(in), dimension(im,jsta_2l:jend_2u,lp1) :: pint, zint - real,intent(in), dimension(im,jsta_2l:jend_2u) :: lmh, prec + real,intent(in), dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm) :: t, q, pmid + real,intent(in), dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lp1) :: pint, zint + real,intent(in), dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: lmh, prec ! ! output: ! real,intent(out) :: ptype(im,jm) - integer,intent(out) :: ptype(im,jsta:jend) + integer,intent(out) :: ptype(ista:iend,jsta:jend) ! integer i,j,ifrzl,iwrml,l,lhiwrm,lmhk,jlen real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2 @@ -97,7 +99,7 @@ subroutine calwxt_bourg_post(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & ! !$omp parallel do do j=jsta,jend - do i=1,im + do i=ista,iend ptype(i,j) = 0 enddo enddo @@ -117,7 +119,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/MDL2THANDPV.f b/sorc/ncep_post.fd/MDL2THANDPV.f index 5950e3959..7b7a41ce1 100644 --- a/sorc/ncep_post.fd/MDL2THANDPV.f +++ b/sorc/ncep_post.fd/MDL2THANDPV.f @@ -16,6 +16,7 @@ !! 20-03-25 J MENG - remove grib1 !! 20-11-10 J MENG - USE UPP_MATH and UPP_PHYSICS MODULES !! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) +!! 21-10-26 J MENG - 2D DECOMPOSITION !! !! !! USAGE: CALL MDL2THANDPV diff --git a/sorc/ncep_post.fd/PROCESS.f b/sorc/ncep_post.fd/PROCESS.f index 034de6caf..fc19f7ed9 100644 --- a/sorc/ncep_post.fd/PROCESS.f +++ b/sorc/ncep_post.fd/PROCESS.f @@ -76,37 +76,45 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! START SUBROUTINE PROCESS. ! cfld=0 + if(me==0) write(0,*) "PROCESS starts" ! ! COMPUTE/POST FIELDS ON MDL SURFACES. ! btim = mpi_wtime() CALL MDLFLD + if(me==0) write(0,*) "PROCESS MDLFLD done" ETAFLD2_tim = ETAFLD2_tim +(mpi_wtime() - btim) ! ! COMPUTE/POST FIELDS ON PRESSURE SURFACES. btim = mpi_wtime() CALL MDL2P(iostatusD3D) + if(me==0) write(0,*) "PROCESS MDL2P done" ETA2P_tim = ETA2P_tim +(mpi_wtime() - btim) ! ! COMPUTE/POST FIELDS ON SIGMA SURFACES. btim = mpi_wtime() CALL MDL2SIGMA + if(me==0) write(0,*) "PROCESS MDL2SIGMA done" CALL MDL2SIGMA2 + if(me==0) write(0,*) "PROCESS MDL2SIGMA2 done" MDL2SIGMA_tim = MDL2SIGMA_tim +(mpi_wtime() - btim) ! ! COMPUTE/POST FIELDS ON AGL SURFCES. btim = mpi_wtime() CALL MDL2AGL + if(me==0) write(0,*) "PROCESS MDL2AGL done" MDL2AGL_tim = MDL2AGL_tim +(mpi_wtime() - btim) ! ! COMPUTE/POST SURFACE RELATED FIELDS. btim = mpi_wtime() CALL SURFCE + if(me==0) write(0,*) "PROCESS SURFCE done" SURFCE2_tim = SURFCE2_tim +(mpi_wtime() - btim) ! ! COMPUTE/POST SOUNDING AND CLOUD RELATED FIELDS. btim = mpi_wtime() CALL CLDRAD + if(me==0) write(0,*) "PROCESS CLDRAD done" CLDRAD_tim = CLDRAD_tim +(mpi_wtime() - btim) ! ! COMPUTE/POST TROPOPAUSE DATA, FD LEVEL FIELDS, @@ -114,6 +122,7 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! AND LFM-NGM LOOK-ALIKE FIELDS. btim = mpi_wtime() CALL MISCLN + if(me==0) write(0,*) "PROCESS MISCLN done" MISCLN_tim = MISCLN_tim +(mpi_wtime() - btim) ! COMPUTE/POST TROPOPAUSE DATA, FD LEVEL FIELDS, @@ -121,27 +130,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/SURFCE.f b/sorc/ncep_post.fd/SURFCE.f index c5395e56a..c9fea0461 100644 --- a/sorc/ncep_post.fd/SURFCE.f +++ b/sorc/ncep_post.fd/SURFCE.f @@ -39,7 +39,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-09-13 J MENG - 2D DECOMPOSITION +!! - 21-10-31 J MENG - 2D DECOMPOSITION !! !! USAGE: CALL SURFCE !! INPUT ARGUMENT LIST: @@ -4225,7 +4225,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' @@ -4437,7 +4437,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 sec CALWXT_BOURG_POST' - 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,AVGPREC,ZINT,IWX1,me) ! write(0,*)'in SURFCE,me=',me,'aft sec CALWXT_BOURG_POST' diff --git a/sorc/ncep_post.fd/UPP_MATH.f b/sorc/ncep_post.fd/UPP_MATH.f index a05a35566..47360d95b 100644 --- a/sorc/ncep_post.fd/UPP_MATH.f +++ b/sorc/ncep_post.fd/UPP_MATH.f @@ -134,7 +134,7 @@ subroutine H2U(ingrid,outgrid) 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=ISTA_M,IEND_M IE=I+MOD(J,2) @@ -143,7 +143,7 @@ subroutine H2U(ingrid,outgrid) 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=ISTA,IEND_M outgrid(i,j)=(ingrid(i,j)+ingrid(i,j+1)+ingrid(i+1,j)+ingrid(i+1,j+1))/4.0 @@ -151,11 +151,11 @@ subroutine H2U(ingrid,outgrid) end do ! Fill in boundary points because hysplit fails when 10 m wind has bitmaps do j=jsta,jend_m - outgrid(im,j)=outgrid(im-1,j) + outgrid(iend,j)=outgrid(iend-1,j) end do IF(me == (num_procs-1) .and. jend_2u >= jm) then DO I=ISTA,IEND - outgrid(i,jm) = outgrid(i,jm-1) + outgrid(i,jend) = outgrid(i,jend-1) END DO END IF ELSE IF(GRIDTYPE == 'C')THEN @@ -189,7 +189,7 @@ subroutine H2V(ingrid,outgrid) 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=ISTA_M,IEND_M IE=I+MOD(J,2) @@ -198,14 +198,14 @@ subroutine H2V(ingrid,outgrid) 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=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=ISTA,IEND outgrid(i,j)=(ingrid(i,j)+ingrid(i,j+1))/2.0 @@ -236,7 +236,7 @@ subroutine U2H(ingrid,outgrid) 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=ISTA_M,IEND_M IE=I+MOD(J+1,2) @@ -245,7 +245,7 @@ subroutine U2H(ingrid,outgrid) 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=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 @@ -282,7 +282,7 @@ subroutine V2H(ingrid,outgrid) 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=ISTA_M,IEND_M IE=I+MOD(J,2) @@ -291,14 +291,14 @@ subroutine V2H(ingrid,outgrid) 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=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=ISTA,IEND outgrid(i,j)=(ingrid(i,j-1)+ingrid(i,j))/2.0 diff --git a/ush/gfs_nceppost.sh b/ush/gfs_nceppost.sh index 975bdc6a6..9e9fefb6e 100755 --- a/ush/gfs_nceppost.sh +++ b/ush/gfs_nceppost.sh @@ -292,7 +292,7 @@ export pgm=$PGM $LOGSCRIPT cat <postgp.inp.nml$$ &NAMPGB - $POSTGPVARS + $POSTGPVARS numx=1, EOF cat <>postgp.inp.nml$$ From 1e5577c51c651bb046317c336deb1d0950969506 Mon Sep 17 00:00:00 2001 From: Bo Cui Date: Sat, 6 Nov 2021 15:42:56 -0400 Subject: [PATCH 43/77] 20211106 Bo Cui commit progress of 2D decomposition --- sorc/ncep_post.fd/CALMICT.f | 23 +++-- sorc/ncep_post.fd/CALPBL.f | 28 +++--- sorc/ncep_post.fd/CALPBLREGIME.f | 9 +- sorc/ncep_post.fd/CALPOT.f | 9 +- sorc/ncep_post.fd/CALPW.f | 57 +++++------ sorc/ncep_post.fd/CALRAD_WCLOUD_newcrtm.f | 109 +++++++++++----------- sorc/ncep_post.fd/CALRCH.f | 16 ++-- sorc/ncep_post.fd/CALSTRM.f | 9 +- sorc/ncep_post.fd/CALTAU.f | 17 ++-- sorc/ncep_post.fd/CALTHTE.f | 13 +-- 10 files changed, 152 insertions(+), 138 deletions(-) diff --git a/sorc/ncep_post.fd/CALMICT.f b/sorc/ncep_post.fd/CALMICT.f index 543610f10..e4998cc32 100644 --- a/sorc/ncep_post.fd/CALMICT.f +++ b/sorc/ncep_post.fd/CALMICT.f @@ -15,6 +15,7 @@ !! 04-11-17 H CHUANG - WRF VERSION !! 14-03-11 B Ferrier - Created new & old versions of this subroutine !! to process new & old versions of the microphysics +!! 21-09-02 Bo Cui - Decompose UPP in X direction !! !! USAGE: CALL CALMICT_new(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL !! &, QW1,QI1,QR1,QS1,DBZ1,DBZR1,DBZI1,DBZC1) @@ -58,7 +59,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 @@ -70,9 +72,9 @@ SUBROUTINE CALMICT_new(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & REAL, PARAMETER :: Cice=1.634e13, Cwet=1./.189, Cboth=Cice/.224, & & NLI_min=1.E3, RFmax=45.259, RQmix=0.1E-3,NSI_max=250.E3 !aligo - real,dimension(IM,jsta_2l:jend_2u),intent(in) :: P1D,T1D,Q1D,C1D,FI1D,FR1D, & + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: P1D,T1D,Q1D,C1D,FI1D,FR1D, & FS1D,CUREFL - real,dimension(IM,jsta_2l:jend_2u),intent(inout) :: QW1,QI1,QR1,QS1,DBZ1,DBZR1,& + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(inout) :: QW1,QI1,QR1,QS1,DBZ1,DBZR1,& DBZI1,DBZC1,NLICE1,NRAIN1 integer I,J @@ -88,7 +90,7 @@ SUBROUTINE CALMICT_new(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & ! Zmin=10.**(0.1*DBZmin) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND QW1(I,J)=0. QI1(I,J)=0. QR1(I,J)=0. @@ -102,7 +104,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 @@ -381,7 +383,8 @@ SUBROUTINE CALMICT_old(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & !$$$ ! use params_mod, only: dbzmin, epsq, tfrz, eps, rd, d608, oneps, nlimin - use ctlblk_mod, only: jsta, jend, jsta_2l, jend_2u, im + use ctlblk_mod, only: jsta, jend, jsta_2l, jend_2u, im, & + ista, iend, ista_2l, iend_2u use rhgrd_mod, only: rhgrd use cmassi_mod, only: t_ice, rqr_drmin, n0rmin, cn0r_dmrmin, mdrmin, & rqr_drmax,cn0r_dmrmax, mdrmax, n0r0, xmrmin, xmrmax,flarge2, & @@ -392,9 +395,9 @@ SUBROUTINE CALMICT_old(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & INTEGER INDEXS, INDEXR REAL, PARAMETER :: Cice=1.634e13 - real,dimension(IM,jsta_2l:jend_2u),intent(in) :: P1D,T1D,Q1D,C1D,FI1D,FR1D, & + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: P1D,T1D,Q1D,C1D,FI1D,FR1D, & FS1D,CUREFL - real,dimension(IM,jsta_2l:jend_2u),intent(inout) :: QW1,QI1,QR1,QS1,DBZ1,DBZR1,& + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(inout) :: QW1,QI1,QR1,QS1,DBZ1,DBZR1,& DBZI1,DBZC1,NLICE1,NRAIN1 REAL N0r,Ztot,Zrain,Zice,Zconv,Zmin @@ -409,7 +412,7 @@ SUBROUTINE CALMICT_old(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & ! Zmin=10.**(0.1*DBZmin) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND QW1(I,J)=0. QI1(I,J)=0. QR1(I,J)=0. @@ -423,7 +426,7 @@ SUBROUTINE CALMICT_old(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & ENDDO ENDDO DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Zrain=0. !--- Radar reflectivity from rain Zice=0. !--- Radar reflectivity from ice Zconv=CUREFL(I,J) !--- Radar reflectivity from convection diff --git a/sorc/ncep_post.fd/CALPBL.f b/sorc/ncep_post.fd/CALPBL.f index d71f9676a..338690712 100644 --- a/sorc/ncep_post.fd/CALPBL.f +++ b/sorc/ncep_post.fd/CALPBL.f @@ -8,6 +8,7 @@ !! !! PROGRAM HISTORY LOG: !! 06-05-04 M TSIDULKO +!! 21-09-02 Bo Cui - Decompose UPP in X direction !! !! USAGE: CALL CALPBL(PBLRI) !! INPUT ARGUMENT LIST: @@ -36,22 +37,23 @@ SUBROUTINE CALPBL(PBLRI) use vrbls2d, only: fis use masks, only: vtm use params_mod, only: h10e5, capa, d608, h1, g, gi - use ctlblk_mod, only: lm, im, jsta, jend, spval, jsta_m, jsta_2l, jend_2u, jend_m + use ctlblk_mod, only: lm, im, jsta, jend, spval, jsta_m, jsta_2l, jend_2u, jend_m, & + ista, iend, ista_m, ista_2l, iend_2u, iend_m use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! DECLARE VARIABLES. ! - real,dimension(IM,jsta_2l:jend_2u),intent(inout) :: PBLRI + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(inout) :: PBLRI REAL, ALLOCATABLE :: THV(:,:,:) - INTEGER IFRSTLEV(IM,jsta_2l:jend_2u),ICALPBL(IM,jsta_2l:jend_2u) & - ,LVLP(IM,jsta_2l:jend_2u) - REAL RIF(IM,jsta_2l:jend_2u) & - ,RIBP(IM,jsta_2l:jend_2u),UBOT1(IM,jsta_2l:jend_2u) & - ,VBOT1(IM,jsta_2l:jend_2u),ZBOT1(IM,jsta_2l:jend_2u) & - ,THVBOT1(IM,jsta_2l:jend_2u) + INTEGER IFRSTLEV(ista_2l:iend_2u,jsta_2l:jend_2u),ICALPBL(ista_2l:iend_2u,jsta_2l:jend_2u) & + ,LVLP(ista_2l:iend_2u,jsta_2l:jend_2u) + REAL RIF(ista_2l:iend_2u,jsta_2l:jend_2u) & + ,RIBP(ista_2l:iend_2u,jsta_2l:jend_2u),UBOT1(ista_2l:iend_2u,jsta_2l:jend_2u) & + ,VBOT1(ista_2l:iend_2u,jsta_2l:jend_2u),ZBOT1(ista_2l:iend_2u,jsta_2l:jend_2u) & + ,THVBOT1(ista_2l:iend_2u,jsta_2l:jend_2u) integer I,J,L,IE,IW real APE,BETTA,RICR,USTARR,WMIN,UHKL,ULKL,VHKL,VLKL,WNDSL,WNDSLP, & UBOT,VBOT,VTOP,UTOP,THVTOP,ZTOP,WDL2,RIB @@ -59,13 +61,13 @@ SUBROUTINE CALPBL(PBLRI) !************************************************************************* ! START CALRCHB HERE. ! - ALLOCATE ( THV(IM,JSTA_2L:JEND_2U,LM) ) + ALLOCATE ( THV(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM) ) ! INITIALIZE ARRAYS. ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PBLRI(I,J) = SPVAL ENDDO ENDDO @@ -75,7 +77,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) 1.0) THEN IF(P1D(I,J) > 1.0) THEN diff --git a/sorc/ncep_post.fd/CALPW.f b/sorc/ncep_post.fd/CALPW.f index 2944454c0..a15c067fb 100644 --- a/sorc/ncep_post.fd/CALPW.f +++ b/sorc/ncep_post.fd/CALPW.f @@ -34,6 +34,7 @@ !! 15-07-10 SARAH LU - UPDATE TO CALCULATE ASYMETRY PARAMETER !! 19-07-25 Li(Kate) Zhang - MERGE SARHA LU's update for FV3-Chem !! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE +!! 21-09-02 Bo Cui - Decompose UPP in X direction !! !! USAGE: CALL CALPW(PW) !! INPUT ARGUMENT LIST: @@ -65,7 +66,7 @@ SUBROUTINE CALPW(PW,IDECID) use vrbls4d, only: smoke use masks, only: htm use params_mod, only: tfrz, gi - use ctlblk_mod, only: lm, jsta, jend, im, spval + use ctlblk_mod, only: lm, jsta, jend, im, spval, ista, iend use upp_physics, only: FPVSNEW !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -82,10 +83,10 @@ SUBROUTINE CALPW(PW,IDECID) ! DECLARE VARIABLES. ! integer,intent(in) :: IDECID - real,dimension(IM,jsta:jend),intent(inout) :: PW + real,dimension(ista:iend,jsta:jend),intent(inout) :: PW INTEGER LLMH,I,J,L REAL ALPM,DZ,PM,PWSUM,RHOAIR,DP,ES - REAL QDUM(IM,jsta:jend), PWS(IM,jsta:jend),QS(IM,jsta:jend) + REAL QDUM(ista:iend,jsta:jend), PWS(ista:iend,jsta:jend),QS(ista:iend,jsta:jend) ! !*************************************************************** ! START CALPW HERE. @@ -94,7 +95,7 @@ SUBROUTINE CALPW(PW,IDECID) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PW(i,j) = 0. PWS(i,j) = 0. ENDDO @@ -108,42 +109,42 @@ SUBROUTINE CALPW(PW,IDECID) IF (IDECID <= 1) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = Q(I,J,L) ENDDO ENDDO ELSE IF (IDECID == 2) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = QQW(I,J,L) ENDDO ENDDO ELSE IF (IDECID == 3) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = QQI(I,J,L) ENDDO ENDDO ELSE IF (IDECID == 4) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = QQR(I,J,L) ENDDO ENDDO ELSE IF (IDECID == 5) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = QQS(I,J,L) ENDDO ENDDO ELSE IF (IDECID == 6) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = CWM(I,J,L) ENDDO ENDDO @@ -151,7 +152,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 16) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = QQG(I,J,L) ENDDO ENDDO @@ -160,7 +161,7 @@ SUBROUTINE CALPW(PW,IDECID) !-- Total supercooled liquid !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (T(I,J,L) >= TFRZ) THEN Qdum(I,J) = 0. ELSE @@ -172,7 +173,7 @@ SUBROUTINE CALPW(PW,IDECID) !-- Total melting ice !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (T(I,J,L) <= TFRZ) THEN Qdum(I,J) = 0. ELSE @@ -184,7 +185,7 @@ SUBROUTINE CALPW(PW,IDECID) ! SHORT WAVE T TENDENCY !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = RSWTT(I,J,L) ENDDO ENDDO @@ -192,7 +193,7 @@ SUBROUTINE CALPW(PW,IDECID) ! LONG WAVE T TENDENCY !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = RLWTT(I,J,L) ENDDO ENDDO @@ -200,7 +201,7 @@ SUBROUTINE CALPW(PW,IDECID) ! LATENT HEATING FROM GRID SCALE RAIN/EVAP !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = TRAIN(I,J,L) ENDDO ENDDO @@ -208,7 +209,7 @@ SUBROUTINE CALPW(PW,IDECID) ! LATENT HEATING FROM CONVECTION !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = TCUCN(I,J,L) ENDDO ENDDO @@ -216,7 +217,7 @@ SUBROUTINE CALPW(PW,IDECID) ! MOISTURE CONVERGENCE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = MCVG(I,J,L) ENDDO ENDDO @@ -224,7 +225,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 14) THEN !$omp parallel do private(i,j,es) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = Q(I,J,L) ES = min(FPVSNEW(T(I,J,L)),PMID(I,J,L)) QS(I,J) = CON_EPS*ES/(PMID(I,J,L)+CON_EPSM1*ES) @@ -234,7 +235,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 15) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = O3(I,J,L) ENDDO END DO @@ -243,7 +244,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 17) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = EXT(I,J,L) ENDDO END DO @@ -253,7 +254,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 18) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = SMOKE(I,J,L,1)/1000000000. ENDDO END DO @@ -263,7 +264,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 19) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = TAOD5503D(I,J,L) ENDDO END DO @@ -272,7 +273,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 20) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = SCA(I,J,L) ENDDO END DO @@ -281,7 +282,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 21) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = ASY(I,J,L) ENDDO END DO @@ -289,7 +290,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) max_n_layers)then write(6,*) 'CALRAD: lm > max_n_layers - '// & @@ -707,7 +708,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 @@ -1145,14 +1146,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 @@ -1163,14 +1164,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 @@ -1182,14 +1183,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 @@ -1201,14 +1202,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 @@ -1220,14 +1221,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 @@ -1261,7 +1262,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 @@ -1721,14 +1722,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 @@ -1743,14 +1744,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 @@ -1765,14 +1766,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 @@ -1788,14 +1789,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ixchan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif endif @@ -1807,14 +1808,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 @@ -1828,14 +1829,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 @@ -1850,14 +1851,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 @@ -1872,14 +1873,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ixchan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif endif @@ -1892,14 +1893,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 @@ -1911,14 +1912,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 @@ -1930,14 +1931,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 @@ -1948,14 +1949,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 @@ -1966,14 +1967,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 @@ -1987,14 +1988,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 @@ -2009,14 +2010,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 @@ -2031,14 +2032,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ixchan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif endif @@ -2051,14 +2052,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 @@ -2070,14 +2071,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 @@ -2087,14 +2088,14 @@ SUBROUTINE CALRAD_WCLOUD igot=iget(968+ichan) if(igot>0)then do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,ichan) enddo enddo if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo diff --git a/sorc/ncep_post.fd/CALRCH.f b/sorc/ncep_post.fd/CALRCH.f index 60b5425b6..e177112ac 100644 --- a/sorc/ncep_post.fd/CALRCH.f +++ b/sorc/ncep_post.fd/CALRCH.f @@ -16,6 +16,7 @@ !! 02-01-15 MIKE BALDWIN - WRF VERSION !! 05-02-25 H CHUANG - ADD COMPUTATION FOR NMM E GRID !! 05-07-07 BINBIN ZHOU - ADD RSM FOR A GRID +!! 21-09-02 Bo Cui - Decompose UPP in X direction !! !! USAGE: CALL CALRCH(EL,RICHNO) !! INPUT ARGUMENT LIST: @@ -45,15 +46,16 @@ SUBROUTINE CALRCH(EL,RICHNO) use masks, only: vtm use params_mod, only: h10e5, capa, d608,h1, epsq2, g, beta use ctlblk_mod, only: jsta, jend, spval, lm1, jsta_m, jend_m, im, & - jsta_2l, jend_2u, lm + jsta_2l, jend_2u, lm, & + ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! DECLARE VARIABLES. ! - REAL,intent(in) :: EL(IM,jsta_2l:jend_2u,LM) - REAL,intent(inout) :: RICHNO(IM,jsta_2l:jend_2u,LM) + REAL,intent(in) :: EL(ista_2l:iend_2u,jsta_2l:jend_2u,LM) + REAL,intent(inout) :: RICHNO(ista_2l:iend_2u,jsta_2l:jend_2u,LM) ! REAL, ALLOCATABLE :: THV(:,:,:) integer I,J,L,IW,IE @@ -66,13 +68,13 @@ SUBROUTINE CALRCH(EL,RICHNO) !************************************************************************* ! START CALRCH HERE. ! - ALLOCATE ( THV(IM,JSTA_2L:JEND_2U,LM) ) + ALLOCATE ( THV(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM) ) ! INITIALIZE ARRAYS. ! !$omp parallel do DO L = 1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND RICHNO(I,J,L)=SPVAL ENDDO ENDDO @@ -83,7 +85,7 @@ SUBROUTINE CALRCH(EL,RICHNO) !$omp parallel do private(i,j,ape) DO L=LM,1,-1 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND APE = (H10E5/PMID(I,J,L))**CAPA THV(I,J,L) = (Q(I,J,L)*D608+H1)*T(I,J,L)*APE ENDDO @@ -108,7 +110,7 @@ SUBROUTINE CALRCH(EL,RICHNO) end if DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M ! IF(GRIDTYPE == 'A')THEN UHKL = UH(I,J,L) diff --git a/sorc/ncep_post.fd/CALSTRM.f b/sorc/ncep_post.fd/CALSTRM.f index c9204ccb6..c99390e52 100644 --- a/sorc/ncep_post.fd/CALSTRM.f +++ b/sorc/ncep_post.fd/CALSTRM.f @@ -17,6 +17,7 @@ !! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D !! 00-01-05 JIM TUCCILLO - MPI VERSION !! 02-06-13 MIKE BALDWIN - WRF VERSION +!! 21-09-02 Bo Cui - Decompose UPP in X direction !! !! USAGE: CALL CALSTRM(Z1D,STRM) !! INPUT ARGUMENT LIST: @@ -48,7 +49,7 @@ SUBROUTINE CALSTRM(Z1D,STRM) ! ! use vrbls2d, only: use params_mod, only: g - use ctlblk_mod, only: jsta, jend, im + use ctlblk_mod, only: jsta, jend, im, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -57,8 +58,8 @@ SUBROUTINE CALSTRM(Z1D,STRM) ! DECLARE VARIABLES. ! ! LOGICAL FIRST,OLDRD,RESTRT,RUN,SIGMA,STRD - REAL, dimension(im,jsta:jend), intent(in) :: Z1D - REAL, dimension(im,jsta:jend), intent(inout) :: STRM + REAL, dimension(ista:iend,jsta:jend), intent(in) :: Z1D + REAL, dimension(ista:iend,jsta:jend), intent(inout) :: STRM ! LOGICAL OLDRD,STRD integer IMID,I,J @@ -76,7 +77,7 @@ SUBROUTINE CALSTRM(Z1D,STRM) ! COMPUTE GEOSTROPHIC STREAMFUNCTION. !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND STRM(I,J) = GOF0*Z1D(I,J) ENDDO ENDDO diff --git a/sorc/ncep_post.fd/CALTAU.f b/sorc/ncep_post.fd/CALTAU.f index 79bae45d3..d9f36302c 100644 --- a/sorc/ncep_post.fd/CALTAU.f +++ b/sorc/ncep_post.fd/CALTAU.f @@ -18,6 +18,7 @@ !! 05-02-23 H CHUANG - COMPUTE STRESS FOR NMM ON WIND POINTS !! 05-07-07 BINBIN ZHOU - ADD RSM STRESS for A GRID !! 21-07-26 W Meng - Restrict computation from undefined grids +!! 21-09-02 Bo Cui - Decompose UPP in X direction !! USAGE: CALL CALTAU(TAUX,TAUY) !! INPUT ARGUMENT LIST: !! NONE @@ -50,7 +51,7 @@ SUBROUTINE CALTAU(TAUX,TAUY) use masks, only: lmh use params_mod, only: d00, d50, h1, d608, rd, d25 use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, spval, jsta_m,& - jm, im, jend_m + jm, im, jend_m, ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype implicit none @@ -58,9 +59,9 @@ SUBROUTINE CALTAU(TAUX,TAUY) ! DECLARE VARIABLES. INTEGER, dimension(4) :: KK(4) INTEGER, dimension(jm) :: ive, ivw - REAL, dimension(im,jsta:jend), intent(inout) :: TAUX, TAUY + REAL, dimension(ista:iend,jsta:jend), intent(inout) :: TAUX, TAUY REAL, ALLOCATABLE :: EL(:,:,:) - REAL, dimension(im,jsta:jend) :: EGRIDU,EGRIDV,EGRID4,EGRID5, EL0 + REAL, dimension(ista:iend,jsta:jend) :: EGRIDU,EGRIDV,EGRID4,EGRID5, EL0 REAL UZ0V,VZ0V CHARACTER*1 AGRID integer I,J,LMHK,IE,IW,ii,jj @@ -70,7 +71,7 @@ SUBROUTINE CALTAU(TAUX,TAUY) !******************************************************************** ! START CALTAU HERE. ! - ALLOCATE (EL(IM,JSTA_2L:JEND_2U,LM)) + ALLOCATE (EL(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM)) ! ! COMPUTE MASTER LENGTH SCALE. ! @@ -80,7 +81,7 @@ SUBROUTINE CALTAU(TAUX,TAUY) ! INITIALIZE OUTPUT AND WORK ARRAY TO ZERO. ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRIDU(I,J) = D00 EGRIDV(I,J) = D00 TAUX(I,J) = SPVAL @@ -97,7 +98,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) Date: Tue, 9 Nov 2021 20:41:23 +0000 Subject: [PATCH 44/77] 20211109 Jesse Meng updates for 2D DECOMPOSITION --- sorc/ncep_post.fd/CLDRAD.f | 74 ++++++------ sorc/ncep_post.fd/MDL2P.f | 4 +- sorc/ncep_post.fd/MDL2STD_P.f | 2 +- sorc/ncep_post.fd/MDLFLD.f | 6 +- sorc/ncep_post.fd/MISCLN.f | 40 +++--- sorc/ncep_post.fd/SCLFLD.f | 2 +- sorc/ncep_post.fd/SURFCE.f | 8 +- sorc/ncep_post.fd/UPP_PHYSICS.f | 208 ++++++++++++++++---------------- 8 files changed, 173 insertions(+), 171 deletions(-) diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index 9ce24163f..a71cf13df 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -421,13 +421,13 @@ SUBROUTINE CLDRAD IF (IGET(080) > 0) THEN ! dong GRID1 = spval - CALL CALPW(GRID1(1,jsta),1) + CALL CALPW(GRID1(ista:iend,jsta:jend),1) DO J=JSTA,JEND DO I=ISTA,IEND IF(FIS(I,J) >= SPVAL) GRID1(I,J)=spval END DO END DO - CALL BOUND(GRID1,D00,H99999) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(080)) @@ -446,8 +446,8 @@ SUBROUTINE CLDRAD ! TOTAL COLUMN AOD (TAOD553D FROM HRRR-SMOKE) ! IF (IGET(735) > 0) THEN - CALL CALPW(GRID1(1,jsta),19) - CALL BOUND(GRID1,D00,H99999) + CALL CALPW(GRID1(ista:iend,jsta:jend),19) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(735)) @@ -466,8 +466,8 @@ SUBROUTINE CLDRAD ! TOTAL COLUMN FIRE SMOKE (tracer_1a FROM HRRR-SMOKE) ! IF (IGET(736) > 0) THEN - CALL CALPW(GRID1(1,jsta),18) - CALL BOUND(GRID1,D00,H99999) + CALL CALPW(GRID1(ista:iend,jsta:iend),18) + CALL BOUND(GRID1(ista:iend,jsta:iend),D00,H99999) if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(736)) @@ -493,10 +493,10 @@ SUBROUTINE CLDRAD 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=ISTA,IEND @@ -510,7 +510,7 @@ SUBROUTINE CLDRAD END IF ! GFS END IF ! RAPR - CALL BOUND(GRID1,D00,H99999) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(IGET(200) > 0) then if(grib == "grib2" )then cfld = cfld + 1 @@ -552,9 +552,9 @@ SUBROUTINE CLDRAD ENDDO ENDDO ELSE - CALL CALPW(GRID1(1,jsta),3) + CALL CALPW(GRID1(ista:iend,jsta:jend),3) END IF - CALL BOUND(GRID1,D00,H99999) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(201)) @@ -571,8 +571,8 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN RAIN IF (IGET(202) > 0) THEN - CALL CALPW(GRID1(1,jsta),4) - CALL BOUND(GRID1,D00,H99999) + CALL CALPW(GRID1(ista:iend,jsta:jend),4) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(202)) @@ -589,8 +589,8 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN SNOW IF (IGET(203) > 0) THEN - CALL CALPW(GRID1(1,jsta),5) - CALL BOUND(GRID1,D00,H99999) + CALL CALPW(GRID1(ista:iend,jsta:jend),5) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(203)) @@ -608,8 +608,8 @@ SUBROUTINE CLDRAD ! SRD ! TOTAL COLUMN GRAUPEL IF (IGET(428) > 0) THEN - CALL CALPW(GRID1(1,jsta),16) - CALL BOUND(GRID1,D00,H99999) + CALL CALPW(GRID1(ista:iend,jsta:jend),16) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(428)) @@ -627,8 +627,8 @@ SUBROUTINE CLDRAD ! TOTAL COLUMN CONDENSATE IF (IGET(204) > 0) THEN - CALL CALPW(GRID1(1,jsta),6) - CALL BOUND(GRID1,D00,H99999) + CALL CALPW(GRID1(ista:iend,jsta:jend),6) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(204)) @@ -645,8 +645,8 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN SUPERCOOLED (<0C) LIQUID WATER IF (IGET(285) > 0) THEN - CALL CALPW(GRID1(1,jsta),7) - CALL BOUND(GRID1,D00,H99999) + CALL CALPW(GRID1(ista:iend,jsta:jend),7) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(285)) @@ -663,8 +663,8 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN MELTING (>0C) ICE IF (IGET(286) > 0) THEN - CALL CALPW(GRID1(1,jsta),8) - CALL BOUND(GRID1,D00,H99999) + CALL CALPW(GRID1(ista:iend,jsta:jend),8) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(286)) @@ -681,7 +681,7 @@ 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)) @@ -698,7 +698,7 @@ 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)) @@ -715,7 +715,7 @@ 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 @@ -766,7 +766,7 @@ 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 @@ -817,7 +817,7 @@ 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)) @@ -827,7 +827,7 @@ SUBROUTINE CLDRAD ! ! 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)) @@ -837,7 +837,7 @@ SUBROUTINE CLDRAD ! ! 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)) @@ -5036,7 +5036,7 @@ SUBROUTINE CLDRAD GRID1(i,j) = AOD(i,j) enddo enddo - CALL BOUND(GRID1,D00,H99999) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(INDX)) @@ -5063,7 +5063,7 @@ SUBROUTINE CLDRAD ENDIF ENDDO ENDDO - CALL BOUND(GRID1,D00,H99999) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(649)) @@ -5087,7 +5087,7 @@ SUBROUTINE CLDRAD ENDIF ENDDO ENDDO - CALL BOUND(GRID1,D00,H99999) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(648)) @@ -5111,7 +5111,7 @@ SUBROUTINE CLDRAD GRID1(I,J)=SCA2D(I,J) ENDDO ENDDO - CALL BOUND(GRID1,D00,H99999) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(650)) @@ -5134,7 +5134,7 @@ SUBROUTINE CLDRAD IF ( II == 5 ) GRID1(I,J) = AOD_BC(I,J) ENDDO ENDDO - CALL BOUND(GRID1,D00,H99999) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(JJ)) @@ -5155,7 +5155,7 @@ SUBROUTINE CLDRAD IF ( II == 5 ) GRID1(I,J) = SCA_BC(I,J) ENDDO ENDDO - CALL BOUND(GRID1,D00,H99999) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(JJ)) @@ -5186,7 +5186,7 @@ SUBROUTINE CLDRAD ENDDO if(debugprint)print *,'output angstrom exp,angst=',maxval(angst(ista:iend,jsta:jend)), & minval(angst(ista:iend,jsta:jend)) - CALL BOUND(GRID1,D00,H99999) + CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(656)) diff --git a/sorc/ncep_post.fd/MDL2P.f b/sorc/ncep_post.fd/MDL2P.f index ad9c53daa..fe33cbe4c 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -1290,7 +1290,7 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO ENDDO ! - CALL CALRH(EGRID2(ista,jsta),TSL(ista,jsta),QSL(ista,jsta),EGRID1(ista,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 @@ -3593,7 +3593,7 @@ SUBROUTINE MDL2P(iostatusD3D) EGRID2(I,J) = SPL(LP) ENDDO ENDDO - CALL CALDWP(EGRID2(ista,jsta),QSL(ista,jsta),TDSL(ista,jsta),TSL(ista,jsta)) + CALL CALDWP(EGRID2(ista:iend,jsta:jend),QSL(ista:iend,jsta:jend),TDSL(ista:iend,jsta:jend),TSL(ista:iend,jsta:jend)) !$omp parallel do private(i,j,dum1,istaa,imois) DO J=JSTA,JEND diff --git a/sorc/ncep_post.fd/MDL2STD_P.f b/sorc/ncep_post.fd/MDL2STD_P.f index 813322621..9d28d60bb 100644 --- a/sorc/ncep_post.fd/MDL2STD_P.f +++ b/sorc/ncep_post.fd/MDL2STD_P.f @@ -492,7 +492,7 @@ SUBROUTINE MDL2STD_P() EGRID4(ISTA:IEND,JSTA:JEND)=QFD(ISTA:IEND,JSTA:JEND,IFD,2) ! Q EGRID1 = SPVAL - CALL CALRH(EGRID2(ista,jsta),EGRID3(ista,jsta),EGRID4(ista,jsta),EGRID1(ista,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 diff --git a/sorc/ncep_post.fd/MDLFLD.f b/sorc/ncep_post.fd/MDLFLD.f index bd932e8d6..f4d83de71 100644 --- a/sorc/ncep_post.fd/MDLFLD.f +++ b/sorc/ncep_post.fd/MDLFLD.f @@ -1591,7 +1591,7 @@ SUBROUTINE MDLFLD ENDDO ENDDO - CALL CALRH(P1D(1,jsta),T1D(1,jsta),Q1D(1,jsta),EGRID4(1,jsta)) + CALL CALRH(P1D(ista:iend,jsta:jend),T1D(ista:iend,jsta:jend),Q1D(ista:iend,jsta:jend),EGRID4(ista:iend,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND @@ -3771,8 +3771,8 @@ SUBROUTINE MDLFLD END DO - CALL U2H(GRID1(ista_2l,JSTA_2L),EGRID1) - CALL V2H(GRID2(ista_2l,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=ista,iend diff --git a/sorc/ncep_post.fd/MISCLN.f b/sorc/ncep_post.fd/MISCLN.f index 3bca9ebde..53bf26843 100644 --- a/sorc/ncep_post.fd/MISCLN.f +++ b/sorc/ncep_post.fd/MISCLN.f @@ -309,7 +309,7 @@ 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)) @@ -487,7 +487,7 @@ SUBROUTINE MISCLN ! ICAO HEIGHT OF TROPOPAUSE IF (IGET(399)>0) THEN - CALL ICAOHEIGHT(P1D, GRID1(ista,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 @@ -549,7 +549,7 @@ SUBROUTINE MISCLN ! ! TROPOPAUSE POTENTIAL TEMPERATURE. IF (IGET(108) > 0) THEN - CALL CALPOT(P1D,T1D,GRID1(ista,jsta)) + CALL CALPOT(P1D,T1D,GRID1(ista:iend,jsta:jend)) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(108)) @@ -689,7 +689,7 @@ SUBROUTINE MISCLN ENDIF ! ICAO HEIGHT OF MAX WIND LEVEL IF (IGET(398)>0) THEN - CALL ICAOHEIGHT(MAXWP, GRID1(ista,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 @@ -1501,7 +1501,7 @@ SUBROUTINE MISCLN 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 @@ -1862,7 +1862,7 @@ SUBROUTINE MISCLN ! BOUNDARY LAYER POTENTIAL TEMPERATURE. IF (IGET(069)>0) THEN IF (LVLS(LBND,IGET(069))>0) THEN - CALL CALPOT(PBND(ista,jsta,LBND),TBND(ista,jsta,LBND),GRID1(ista,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)) @@ -1888,7 +1888,7 @@ SUBROUTINE MISCLN 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 @@ -1910,7 +1910,7 @@ SUBROUTINE MISCLN IF (IGET(070)>0) THEN IF (LVLS(LBND,IGET(070))>0) THEN CALL CALDWP(PBND(ista,jsta,LBND), QBND(ista,jsta,LBND), & - GRID1(ista,jsta), TBND(ista,jsta,LBND)) + GRID1(ista:iend,jsta:jend), TBND(ista,jsta,LBND)) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(070)) @@ -2089,7 +2089,7 @@ SUBROUTINE MISCLN ! BOUNDARY LAYER LIFTED INDEX. IF (IGET(075)>0 .OR. IGET(031)>0 .OR. IGET(573)>0) THEN CALL OTLFT(PBND(ista,jsta,LBND),TBND(ista,jsta,LBND), & - QBND(ista,jsta,LBND),GRID1(ista,jsta)) + 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 @@ -2615,7 +2615,7 @@ SUBROUTINE MISCLN 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 @@ -2704,7 +2704,7 @@ SUBROUTINE MISCLN 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 @@ -2731,7 +2731,7 @@ SUBROUTINE MISCLN 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 @@ -2756,7 +2756,7 @@ SUBROUTINE MISCLN 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 @@ -2818,7 +2818,7 @@ SUBROUTINE MISCLN 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 @@ -2843,7 +2843,7 @@ SUBROUTINE MISCLN 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 @@ -2868,7 +2868,7 @@ SUBROUTINE MISCLN 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 @@ -2893,7 +2893,7 @@ SUBROUTINE MISCLN 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 @@ -3082,7 +3082,7 @@ SUBROUTINE MISCLN * EGRID1(I,J) ENDDO ENDDO - CALL CALPOT(EGRID2,GRID2(ista,jsta),GRID1(ista,jsta)) + CALL CALPOT(EGRID2,GRID2(ista:iend,jsta:jend),GRID1(ista:iend,jsta:jend)) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(322)) @@ -3979,7 +3979,7 @@ SUBROUTINE MISCLN JSTOP = JEND END IF - IF(gridtype /= 'A') CALL EXCH(FIS(ISTA:IEND,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) @@ -4648,7 +4648,7 @@ 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)) diff --git a/sorc/ncep_post.fd/SCLFLD.f b/sorc/ncep_post.fd/SCLFLD.f index 9c0b2a62c..db2e65724 100644 --- a/sorc/ncep_post.fd/SCLFLD.f +++ b/sorc/ncep_post.fd/SCLFLD.f @@ -51,7 +51,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 ! ! diff --git a/sorc/ncep_post.fd/SURFCE.f b/sorc/ncep_post.fd/SURFCE.f index c9fea0461..13ecada1f 100644 --- a/sorc/ncep_post.fd/SURFCE.f +++ b/sorc/ncep_post.fd/SURFCE.f @@ -1603,7 +1603,7 @@ SUBROUTINE SURFCE ENDIF ENDDO ENDDO - CALL DEWPOINT(EVP,EGRID1(ista,jsta)) + CALL DEWPOINT(EVP,EGRID1(ista:iend,jsta:jend)) ! print *,' MAX DEWPOINT',maxval(egrid1) ! DEWPOINT IF (IGET(113)>0) THEN @@ -1640,7 +1640,7 @@ SUBROUTINE SURFCE 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 @@ -1717,7 +1717,7 @@ SUBROUTINE SURFCE ENDDO ENDDO - CALL CALRH(P1D,T1D,Q1D,EGRID1(ista,jsta)) + CALL CALRH(P1D,T1D,Q1D,EGRID1(ista:iend,jsta:jend)) if (allocated(q1d)) deallocate(q1d) !$omp parallel do private(i,j) @@ -2485,7 +2485,7 @@ SUBROUTINE SURFCE ! IF (IGET(588)>0) THEN - CALL CALVESSEL(ICEG(ista,jsta)) + CALL CALVESSEL(ICEG(ista:iend,jsta:jend)) DO J=JSTA,JEND DO I=ISTA,IEND diff --git a/sorc/ncep_post.fd/UPP_PHYSICS.f b/sorc/ncep_post.fd/UPP_PHYSICS.f index 60a54dee5..d87c908e3 100644 --- a/sorc/ncep_post.fd/UPP_PHYSICS.f +++ b/sorc/ncep_post.fd/UPP_PHYSICS.f @@ -51,12 +51,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) @@ -118,7 +118,7 @@ SUBROUTINE CALRH_NAM(P1,T1,Q1,RH) !$$$ ! use params_mod, only: PQ0, a2, a3, a4, rhmin - use ctlblk_mod, only: jsta, jend, spval, im + use ctlblk_mod, only: ista, iend, jsta, jend, spval !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -126,9 +126,9 @@ SUBROUTINE CALRH_NAM(P1,T1,Q1,RH) ! ! DECLARE VARIABLES. ! - REAL,dimension(IM,jsta:jend),intent(in) :: P1,T1 - REAL,dimension(IM,jsta:jend),intent(inout) :: Q1 - REAL,dimension(IM,jsta:jend),intent(out) :: RH + REAL,dimension(ista:iend,jsta:jend),intent(in) :: P1,T1 + REAL,dimension(ista:iend,jsta:jend),intent(inout) :: Q1 + REAL,dimension(ista:iend,jsta:jend),intent(out) :: RH REAL QC integer I,J !*************************************************************** @@ -136,7 +136,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)) @@ -217,7 +217,7 @@ 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 ! @@ -234,8 +234,8 @@ SUBROUTINE CALRH_GFS(P1,T1,Q1,RH) ! END FUNCTION FPVSNEW ! END INTERFACE ! - REAL,dimension(IM,jsta:jend),intent(in) :: P1,T1 - REAL,dimension(IM,jsta:jend),intent(inout):: Q1,RH + REAL,dimension(ista:iend,jsta:jend),intent(in) :: P1,T1 + REAL,dimension(ista:iend,jsta:jend),intent(inout):: Q1,RH REAL ES,QC integer :: I,J !*************************************************************** @@ -244,7 +244,7 @@ SUBROUTINE CALRH_GFS(P1,T1,Q1,RH) ! !$omp parallel do private(i,j,es,qc) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (T1(I,J) < spval .AND. P1(I,J) < spval.AND.Q1(I,J)/=spval) THEN ! IF (ABS(P1(I,J)) > 1.0) THEN ! IF (P1(I,J) > 1.0) THEN @@ -284,17 +284,17 @@ SUBROUTINE CALRH_GSD(P1,T1,Q1,RHB) !------------------------------------------------------------------ ! - use ctlblk_mod, only: jsta, jend, im, spval + use ctlblk_mod, only: ista, iend, jsta, jend, spval implicit none integer :: j, i real :: tx, pol, esx, es, e - real, dimension(im,jsta:jend) :: P1, T1, Q1, RHB + real, dimension(ista:iend,jsta:jend) :: P1, T1, Q1, RHB DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (T1(I,J) < spval .AND. P1(I,J) < spval .AND. Q1(I,J) < spval) THEN ! - compute relative humidity Tx=T1(I,J)-273.15 @@ -326,13 +326,13 @@ SUBROUTINE CALRH_PW(RHPW) use vrbls3d, only: q, pmid, t use params_mod, only: g - use ctlblk_mod, only: lm, jsta, jend, lm, im, spval + use ctlblk_mod, only: lm, ista, iend, jsta, jend, spval !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none real,PARAMETER :: svp1=6.1153,svp2=17.67,svp3=29.65 - REAL, dimension(im,jsta:jend):: PW, PW_SAT, RHPW + REAL, dimension(ista:iend,jsta:jend):: PW, PW_SAT, RHPW REAL deltp,sh,qv,temp,es,qs,qv_sat integer i,j,l,k,ka,kb @@ -343,7 +343,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 @@ -850,7 +851,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & KNUML = 0 KNUMH = 0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND KLRES(I,J) = 0 KHRES(I,J) = 0 IF(L <= LCL(I,J)) THEN @@ -868,23 +869,23 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE 0) THEN - CALL TTBLEX(TPAR(1,JSTA_2L,L),TTBL,ITB,JTB,KLRES & - , PMID(1,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE & + CALL TTBLEX(TPAR(ISTA_2L,JSTA_2L,L),TTBL,ITB,JTB,KLRES & + , PMID(ISTA_2L,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE & , RDTHE,THESP,IPTB,ITHTB) ENDIF !*** !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PLQ !** IF(KNUMH > 0) THEN - CALL TTBLEX(TPAR(1,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES & - , PMID(1,JSTA_2L,L),PLQ,QQ,PP,RDPQ & + CALL TTBLEX(TPAR(ISTA_2L,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES & + , PMID(ISTA_2L,JSTA_2L,L),PLQ,QQ,PP,RDPQ & ,THE0Q,STHEQ,RDTHEQ,THESP,IPTB,ITHTB) ENDIF !------------SEARCH FOR EQ LEVEL---------------------------------------- !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(KHRES(I,J) > 0) THEN IF(TPAR(I,J,L) > T(I,J,L)) IEQL(I,J) = L ENDIF @@ -893,7 +894,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(KLRES(I,J) > 0) THEN IF(TPAR(I,J,L) > T(I,J,L) .AND. & PMID(I,J,L)>100.) IEQL(I,J) = L @@ -906,7 +907,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & LBEG = 1000 LEND = 0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LBEG = MIN(IEQL(I,J),LBEG) LEND = MAX(LCL(I,J),LEND) ENDDO @@ -914,7 +915,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T(I,J,IEQL(I,J)) > 255.65) THEN THUNDER(I,J) = .FALSE. ENDIF @@ -925,7 +926,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IDX(I,J) = 0 IF(L >= IEQL(I,J).AND.L <= LCL(I,J)) THEN IDX(I,J) = 1 @@ -935,7 +936,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & ! !$omp parallel do private(i,j,gdzkl,presk,thetaa,thetap,esatp,qsatp,tvp,tv) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(IDX(I,J) > 0) THEN PRESK = PMID(I,J,L) GDZKL = (ZINT(I,J,L)-ZINT(I,J,L+1)) * G @@ -966,7 +967,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 @@ -1131,7 +1132,8 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & use lookup_mod, only: thl, rdth, jtb, qs0, sqs, rdq, itb, ptbl, & plq, ttbl, pl, rdp, the0, sthe, rdthe, ttblq, & itbq, jtbq, rdpq, the0q, stheq, rdtheq - use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, im, jm, me, jsta_m, jend_m, spval + use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, im, jm, me, jsta_m, jend_m, spval,& + ista_2l, iend_2u, ista, iend, ista_m, iend_m ! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -1143,25 +1145,25 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ! integer,intent(in) :: ITYPE real,intent(in) :: DPBND - integer, dimension(IM,Jsta:jend),intent(in) :: L1D - real, dimension(IM,Jsta:jend),intent(in) :: P1D,T1D -! real, dimension(IM,jsta:jend),intent(inout) :: Q1D,CAPE,CINS,PPARC,ZEQL - real, dimension(IM,jsta:jend),intent(inout) :: Q1D,CAPE,CINS - real, dimension(IM,jsta:jend) :: PPARC,ZEQL - real, dimension(IM,jsta:jend),intent(inout) :: LFC,ESRHL,ESRHH - real, dimension(IM,jsta:jend),intent(inout) :: DCAPE,DGLD,ESP - integer, dimension(im,jsta:jend) ::L12,L17,L3KM + integer, dimension(ista:iend,Jsta:jend),intent(in) :: L1D + real, dimension(ista:iend,Jsta:jend),intent(in) :: P1D,T1D +! real, dimension(ista:iend,jsta:jend),intent(inout) :: Q1D,CAPE,CINS,PPARC,ZEQL + real, dimension(ista:iend,jsta:jend),intent(inout) :: Q1D,CAPE,CINS + real, dimension(ista:iend,jsta:jend) :: PPARC,ZEQL + real, dimension(ista:iend,jsta:jend),intent(inout) :: LFC,ESRHL,ESRHH + real, dimension(ista:iend,jsta:jend),intent(inout) :: DCAPE,DGLD,ESP + integer, dimension(ista:iend,jsta:jend) ::L12,L17,L3KM ! - integer, dimension(im,jsta:jend) :: IPTB, ITHTB, PARCEL, KLRES, KHRES, LCL, IDX + integer, dimension(ista:iend,jsta:jend) :: IPTB, ITHTB, PARCEL, KLRES, KHRES, LCL, IDX ! - real, dimension(im,jsta:jend) :: THESP, PSP, CAPE20, QQ, PP, THUND - integer, dimension(im,jsta:jend) :: PARCEL2 - real, dimension(im,jsta:jend) :: THESP2,PSP2 - real, dimension(im,jsta:jend) :: CAPE4,CINS4 + real, dimension(ista:iend,jsta:jend) :: THESP, PSP, CAPE20, QQ, PP, THUND + integer, dimension(ista:iend,jsta:jend) :: PARCEL2 + real, dimension(ista:iend,jsta:jend) :: THESP2,PSP2 + real, dimension(ista:iend,jsta:jend) :: CAPE4,CINS4 REAL, ALLOCATABLE :: TPAR(:,:,:) REAL, ALLOCATABLE :: TPAR2(:,:,:) - LOGICAL THUNDER(IM,jsta:jend), NEEDTHUN + LOGICAL THUNDER(ista:iend,jsta:jend), NEEDTHUN real PSFCK,PKL,TBTK,QBTK,APEBTK,TTHBTK,TTHK,APESPK,TPSPK, & BQS00K,SQS00K,BQS10K,SQS10K,BQK,SQK,TQK,PRESK,GDZKL,THETAP, & THETAA,P00K,P10K,P01K,P11K,TTHESK,ESATP,QSATP,TVP,TV @@ -1170,15 +1172,15 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & integer I,J,L,KNUML,KNUMH,LBEG,LEND,IQ, KB,ITTBK integer IE,IW,JN,JS,IVE(JM),IVW(JM),JVN,JVS integer ISTART,ISTOP,JSTART,JSTOP - real, dimension(IM,jsta:jend) :: HTSFC + real, dimension(ista:iend,jsta:jend) :: HTSFC ! integer I,J,L,KNUML,KNUMH,LBEG,LEND,IQ,IT,LMHK, KB,ITTBK ! !************************************************************** ! START CALCAPE HERE. ! - ALLOCATE(TPAR(IM,JSTA_2L:JEND_2U,LM)) - ALLOCATE(TPAR2(IM,JSTA_2L:JEND_2U,LM)) + ALLOCATE(TPAR(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM)) + ALLOCATE(TPAR2(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM)) ! ! COMPUTE CAPE/CINS ! @@ -1202,7 +1204,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ! !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND CAPE(I,J) = D00 CAPE20(I,J) = D00 CAPE4(I,J) = D00 @@ -1230,7 +1232,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !$omp parallel do DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND TPAR(I,J,L) = D00 TPAR2(I,J,L) = D00 ENDDO @@ -1246,8 +1248,8 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & IVE(J) = MOD(J,2) IVW(J) = IVE(J)-1 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE IF(gridtype == 'B')THEN @@ -1257,8 +1259,8 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & IVE(J)=1 IVW(J)=0 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE @@ -1268,13 +1270,13 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & IVE(J) = 0 IVW(J) = 0 enddo - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND END IF !!$omp parallel do private(htsfc,ie,iw) - IF(gridtype /= 'A') CALL EXCH(FIS(1:IM,JSTA:JEND)) + IF(gridtype /= 'A') CALL EXCH(FIS(ISTA:IEND,JSTA:JEND)) DO J=JSTART,JSTOP DO I=ISTART,ISTOP IE = I+IVE(J) @@ -1299,7 +1301,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & IF (ITYPE == 2) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Q1D(I,J) = MIN(MAX(H1M12,Q1D(I,J)),H99999) ENDDO ENDDO @@ -1316,7 +1318,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !$omp & p00k,p01k,p10k,p11k,pkl,psfck,qbtk,sqk,sqs00k, & !$omp & sqs10k,tbtk,tpspk,tqk,tthbtk,tthesk,tthk) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PSFCK = PMID(I,J,NINT(LMH(I,J))) PKL = PMID(I,J,KB) @@ -1412,7 +1414,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !----FIND THE PRESSURE OF THE PARCEL THAT WAS LIFTED !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PPARC(I,J) = PMID(I,J,PARCEL(I,J)) ENDDO ENDDO @@ -1423,14 +1425,14 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & DO L=1,LM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (PMID(I,J,L) < PSP(I,J)) LCL(I,J) = L+1 ENDDO ENDDO ENDDO !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (LCL(I,J) > NINT(LMH(I,J))) LCL(I,J) = NINT(LMH(I,J)) IF (ITYPE > 2) THEN IF (T(I,J,LCL(I,J)) < 263.15) THEN @@ -1447,7 +1449,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & KNUML = 0 KNUMH = 0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND KLRES(I,J) = 0 KHRES(I,J) = 0 IF(L <= LCL(I,J)) THEN @@ -1465,23 +1467,23 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE 0) THEN - CALL TTBLEX(TPAR(1,JSTA_2L,L),TTBL,ITB,JTB,KLRES & - , PMID(1,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE & + CALL TTBLEX(TPAR(ISTA_2L,JSTA_2L,L),TTBL,ITB,JTB,KLRES & + , PMID(ISTA_2L,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE & , RDTHE,THESP,IPTB,ITHTB) ENDIF !*** !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PLQ !** IF(KNUMH > 0) THEN - CALL TTBLEX(TPAR(1,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES & - , PMID(1,JSTA_2L,L),PLQ,QQ,PP,RDPQ & + CALL TTBLEX(TPAR(ISTA_2L,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES & + , PMID(ISTA_2L,JSTA_2L,L),PLQ,QQ,PP,RDPQ & ,THE0Q,STHEQ,RDTHEQ,THESP,IPTB,ITHTB) ENDIF !------------SEARCH FOR EQ LEVEL---------------------------------------- !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(KHRES(I,J) > 0) THEN IF(TPAR(I,J,L) > T(I,J,L)) IEQL(I,J) = L ENDIF @@ -1490,7 +1492,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(KLRES(I,J) > 0) THEN IF(TPAR(I,J,L) > T(I,J,L)) IEQL(I,J) = L ENDIF @@ -1502,7 +1504,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & LBEG = 1000 LEND = 0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LBEG = MIN(IEQL(I,J),LBEG) LEND = MAX(LCL(I,J),LEND) ENDDO @@ -1510,7 +1512,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T(I,J,IEQL(I,J)) > 255.65) THEN THUNDER(I,J) = .FALSE. ENDIF @@ -1526,7 +1528,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IDX(I,J) = 0 IF(L >= IEQL(I,J).AND.L <= LCL(I,J)) THEN IDX(I,J) = 1 @@ -1537,7 +1539,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !$omp parallel do private(i,j,gdzkl,presk,thetaa,thetap,esatp,qsatp,tvp,tv,& !$omp & presk2,esatp2,qsatp2,tvp2,thetap2,tv2,thetaa2) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(IDX(I,J) > 0) THEN PRESK = PMID(I,J,L) GDZKL = (ZINT(I,J,L)-ZINT(I,J,L+1)) * G @@ -1598,7 +1600,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ESRHH(I,J) > ESRHL(I,J)) ESRHH(I,J)=IEQL(I,J) ENDDO ENDDO @@ -1609,7 +1611,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND CAPE(I,J) = MAX(D00,CAPE(I,J)) CINS(I,J) = MIN(CINS(I,J),D00) ! equillibrium height @@ -1637,7 +1639,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & KNUML = 0 KNUMH = 0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND KLRES(I,J) = 0 KHRES(I,J) = 0 PSFCK = PMID(I,J,NINT(LMH(I,J))) @@ -1657,16 +1659,16 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE 0) THEN - CALL TTBLEX(TPAR2(1,JSTA_2L,L),TTBL,ITB,JTB,KLRES & - , PMID(1,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE & + CALL TTBLEX(TPAR2(ISTA_2L,JSTA_2L,L),TTBL,ITB,JTB,KLRES & + , PMID(ISTA_2L,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE & , RDTHE,THESP2,IPTB,ITHTB) ENDIF !*** !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PLQ !** IF(KNUMH > 0) THEN - CALL TTBLEX(TPAR2(1,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES & - , PMID(1,JSTA_2L,L),PLQ,QQ,PP,RDPQ & + CALL TTBLEX(TPAR2(ISTA_2L,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES & + , PMID(ISTA_2L,JSTA_2L,L),PLQ,QQ,PP,RDPQ & , THE0Q,STHEQ,RDTHEQ,THESP2,IPTB,ITHTB) ENDIF ENDDO ! end of do l=lm,1,-1 loop @@ -1677,7 +1679,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & DO L=LBEG,LEND !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IDX(I,J) = 0 IF(L >= PARCEL2(I,J).AND.L < NINT(LMH(I,J))) THEN IDX(I,J) = 1 @@ -1687,7 +1689,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ! !$omp parallel do private(i,j,gdzkl,presk,thetaa,thetap,esatp,qsatp,tvp,tv) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(IDX(I,J) > 0) THEN PRESK = PMID(I,J,L) GDZKL = (ZINT(I,J,L)-ZINT(I,J,L+1)) * G @@ -1709,7 +1711,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND DCAPE(I,J) = MIN(D00,DCAPE(I,J)) ENDDO ENDDO @@ -1725,7 +1727,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & DO L=LM,1,-1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T(I,J,L) <= TFRZ-12. .AND. L12(I,J)==LM) L12(I,J)=L IF(T(I,J,L) <= TFRZ-17. .AND. L17(I,J)==LM) L17(I,J)=L ENDDO @@ -1733,7 +1735,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ENDDO !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(L12(I,J)/=LM .AND. L17(I,J)/=LM) THEN DGLD(I,J)=ZINT(I,J,L17(I,J))-ZINT(I,J,L12(I,J)) DGLD(I,J)=MAX(DGLD(I,J),0.) @@ -1749,14 +1751,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. From 8d88e6cae232a67314b01f1610f095cc0d0e2353 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Wed, 10 Nov 2021 21:49:13 +0000 Subject: [PATCH 45/77] 20211110 Jesse Meng updates in 2D DECOMPOSITION --- sorc/ncep_post.fd/MDL2P.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/sorc/ncep_post.fd/MDL2P.f b/sorc/ncep_post.fd/MDL2P.f index fe33cbe4c..965a664e5 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -3637,7 +3637,7 @@ SUBROUTINE MDL2P(iostatusD3D) EGRID2(I,J) = SPL(LP) ENDDO ENDDO - CALL CALDWP(EGRID2(ista,jsta),QSL(ista,jsta),TDSL(ista,jsta),TSL(ista,jsta)) + CALL CALDWP(EGRID2(ista:iend,jsta:jend),QSL(ista:iend,jsta:jend),TDSL(ista:iend,jsta:jend),TSL(ista:iend,jsta:jend)) !$omp parallel do private(i,j,dum1,istaa,imois) DO J=JSTA,JEND @@ -3681,7 +3681,7 @@ SUBROUTINE MDL2P(iostatusD3D) EGRID2(I,J)=SPL(LP) ENDDO ENDDO - CALL CALDWP(EGRID2(ista,jsta),QSL(ista,jsta),TDSL(ista,jsta),TSL(ista,jsta)) + CALL CALDWP(EGRID2(ista:iend,jsta:jend),QSL(ista:iend,jsta:jend),TDSL(ista:iend,jsta:jend),TSL(ista:iend,jsta:jend)) !$omp parallel do private(i,j,dum1,istaa,imois) DO J=JSTA,JEND From db532a10944b0948cfa8f047d2097ade45ba44ce Mon Sep 17 00:00:00 2001 From: wx22mj Date: Fri, 12 Nov 2021 22:11:11 +0000 Subject: [PATCH 46/77] 20211112 Jesse Meng updates for 2D DECOMPOSITION --- sorc/ncep_post.fd/FIXED.f | 2 +- sorc/ncep_post.fd/MDL2P.f | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/sorc/ncep_post.fd/FIXED.f b/sorc/ncep_post.fd/FIXED.f index 395f2c91c..916cd6da3 100644 --- a/sorc/ncep_post.fd/FIXED.f +++ b/sorc/ncep_post.fd/FIXED.f @@ -186,7 +186,7 @@ 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)) diff --git a/sorc/ncep_post.fd/MDL2P.f b/sorc/ncep_post.fd/MDL2P.f index 965a664e5..3d809e18e 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -1513,7 +1513,7 @@ SUBROUTINE MDL2P(iostatusD3D) !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 From af345c2d2f8a99d4ffc6322c2b779a0cc496e0ad Mon Sep 17 00:00:00 2001 From: wx22mj Date: Mon, 15 Nov 2021 19:07:04 +0000 Subject: [PATCH 47/77] 20211115 Jesse Meng updates for 2D DECOMPOSITION --- sorc/ncep_post.fd/CALMCVG.f | 3 ++- sorc/ncep_post.fd/NGMFLD.f | 6 +++--- sorc/ncep_post.fd/WRFPOST.f | 4 +++- 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/sorc/ncep_post.fd/CALMCVG.f b/sorc/ncep_post.fd/CALMCVG.f index 5b991095f..fa726809f 100644 --- a/sorc/ncep_post.fd/CALMCVG.f +++ b/sorc/ncep_post.fd/CALMCVG.f @@ -99,6 +99,7 @@ SUBROUTINE CALMCVG(Q1D,U1D,V1D,QCNVG) CALL EXCH(Q1D) CALL EXCH(VWND) + CALL EXCH(UWND) ! IF(gridtype == 'A')THEN !$omp parallel do private(i,j,qudx,qvdy,r2dx,r2dy) @@ -169,7 +170,7 @@ SUBROUTINE CALMCVG(Q1D,U1D,V1D,QCNVG) ENDDO ELSE IF(gridtype=='B')THEN - CALL EXCH(UWND) +! CALL EXCH(UWND) ! !$omp parallel do private(i,j,qudx,qvdy,r2dx,r2dy) DO J=JSTA_M,JEND_M diff --git a/sorc/ncep_post.fd/NGMFLD.f b/sorc/ncep_post.fd/NGMFLD.f index 022c643f4..48d2461e9 100644 --- a/sorc/ncep_post.fd/NGMFLD.f +++ b/sorc/ncep_post.fd/NGMFLD.f @@ -87,7 +87,7 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510) 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, & - ista, iend, ista_2l, iend_2u, ista_m2, iend_m2 + ista, iend, ista_2l, iend_2u, ista_m2, iend_m2, ista_m, iend_m ! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -148,7 +148,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=ISTA_M2,IEND_M2 + DO I=ISTA_M,IEND_M ! ! SET TARGET PRESSURES. @@ -222,7 +222,7 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510) ENDDO ! DO J=JSTA_M2,JEND_M2 - DO I=ISTA_M2,IEND_M2 + 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/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f index 706589d7b..7540060f5 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -241,7 +241,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 (me==0) print*,'numx= ',numx ! if(MODELNAME == 'NMM')then ! read(5,1114) VTIMEUNITS ! 1114 format(a4) @@ -322,6 +322,8 @@ PROGRAM WRFPOST 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 ! set up pressure level from POSTGPVARS or DEFAULT From 045f79772f6c267823ef2502cd7e82920d37f20a Mon Sep 17 00:00:00 2001 From: wx22mj Date: Fri, 19 Nov 2021 20:41:47 +0000 Subject: [PATCH 48/77] 20211119 Jesse Meng updates for 2D DECOMPOSITION --- sorc/ncep_post.fd/CALPBL.f | 16 ++++++++-------- sorc/ncep_post.fd/COLLECT_LOC.f | 1 + 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/sorc/ncep_post.fd/CALPBL.f b/sorc/ncep_post.fd/CALPBL.f index 338690712..b3c6e0d20 100644 --- a/sorc/ncep_post.fd/CALPBL.f +++ b/sorc/ncep_post.fd/CALPBL.f @@ -119,14 +119,14 @@ SUBROUTINE CALPBL(PBLRI) USTARR = 0.1 WMIN = 0.01 ! - if(GRIDTYPE /= 'A') THEN - call exch(VTM(1,jsta_2l,L)) - call exch(UH(1,jsta_2l,L)) - call exch(VH(1,jsta_2l,L)) - call exch(VTM(1,jsta_2l,L-1)) - call exch(UH(1,jsta_2l,L-1)) - call exch(VH(1,jsta_2l,L-1)) - end if +! if(GRIDTYPE /= 'A') THEN + call exch(VTM(ista_2l,jsta_2l,L)) + call exch(UH(ista_2l,jsta_2l,L)) + call exch(VH(ista_2l,jsta_2l,L)) + call exch(VTM(ista_2l,jsta_2l,L-1)) + call exch(UH(ista_2l,jsta_2l,L-1)) + call exch(VH(ista_2l,jsta_2l,L-1)) +! end if DO J=JSTA_M,JEND_M DO I=ISTA_M,IEND_M diff --git a/sorc/ncep_post.fd/COLLECT_LOC.f b/sorc/ncep_post.fd/COLLECT_LOC.f index 868fba9dc..652b126de 100644 --- a/sorc/ncep_post.fd/COLLECT_LOC.f +++ b/sorc/ncep_post.fd/COLLECT_LOC.f @@ -88,5 +88,6 @@ SUBROUTINE COLLECT_LOC ( A, B ) end if endif deallocate(buff) + deallocate(rbufs) end From d518f81b2506f1bd3a7414f22f6e9ff1933bcb9d Mon Sep 17 00:00:00 2001 From: wx22mj Date: Thu, 2 Dec 2021 03:08:54 +0000 Subject: [PATCH 49/77] 20211201 Jesse Meng move CALVOR to UPP_PHYSICS module; implement fullpole in MPI_FIRST --- sorc/ncep_post.fd/CALVOR.f | 947 ------------------- sorc/ncep_post.fd/CMakeLists.txt | 1 - sorc/ncep_post.fd/CTLBLK.f | 5 +- sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f | 2 +- sorc/ncep_post.fd/MDL2P.f | 2 +- sorc/ncep_post.fd/MDL2STD_P.f | 2 +- sorc/ncep_post.fd/MDLFLD.f | 2 +- sorc/ncep_post.fd/MPI_FIRST.f | 148 ++- sorc/ncep_post.fd/UPP_PHYSICS.f | 998 ++++++++++++++++++++ sorc/ncep_post.fd/WRFPOST.f | 8 +- sorc/ncep_post.fd/makefile_module | 3 +- ush/gfs_nceppost.sh | 2 +- 12 files changed, 1156 insertions(+), 964 deletions(-) delete mode 100644 sorc/ncep_post.fd/CALVOR.f diff --git a/sorc/ncep_post.fd/CALVOR.f b/sorc/ncep_post.fd/CALVOR.f deleted file mode 100644 index 3f4c6adf6..000000000 --- a/sorc/ncep_post.fd/CALVOR.f +++ /dev/null @@ -1,947 +0,0 @@ -!> @file -! -!> SUBPROGRAM: CALVOR COMPUTES ABSOLUTE VORTICITY -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE ABSOLUTE VORTICITY. -!! -!! PROGRAM HISTORY LOG: -!! 92-12-22 RUSS TREADON -!! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-01-15 MIKE BALDWIN - WRF VERSION C-GRID -!! 05-03-01 H CHUANG - ADD NMM E GRID -!! 05-05-17 H CHUANG - ADD POTENTIAL VORTICITY CALCULATION -!! 05-07-07 B ZHOU - ADD RSM IN COMPUTING DVDX, DUDY AND UAVG -!! 13-08-09 S MOORTHI - Optimize the vorticity loop including threading -!! 16-08-05 S Moorthi - add zonal filetering -!! 2019-10-17 Y Mao - Skip calculation when U/V is SPVAL -!! 2020-11-06 J Meng - USE UPP_MATH MODULE -!! 21-09-02 Bo Cui - Decompose UPP in X direction, REPLACE EXCH_F to EXCH -!! 21-10-31 J MENG - 2D DECOMPOSITION -!! -!! USAGE: CALL CALVOR(UWND,VWND,ABSV) -!! INPUT ARGUMENT LIST: -!! UWND - U WIND (M/S) MASS-POINTS -!! VWND - V WIND (M/S) MASS-POINTS -!! -!! OUTPUT ARGUMENT LIST: -!! ABSV - ABSOLUTE VORTICITY (1/S) MASS-POINTS -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : WCOSS -!! - SUBROUTINE CALVOR(UWND,VWND,ABSV) - -! -! - use vrbls2d, only: f - use masks, only: gdlat, gdlon, dx, dy - use params_mod, only: d00, dtr, small, erad - use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, & - jsta, jend, im, jm, jsta_m, jend_m, gdsdegr,& - ista, iend, ista_m, iend_m, ista_2l, iend_2u - 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, 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) - -!$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 - - 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(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 - 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=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 - 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=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 - 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=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 - 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=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)) - 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)= 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 - - 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)) - -!$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) & - & + 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) & - & + 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) - 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) - 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)) -!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) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALGRADPS COMPUTES GRADIENTS OF A SCALAR FIELD PS OR LNPS -! PRGRMMR: SAJAL KAR ORG: W/NP2 DATE: 16-05-05 -! -! ABSTRACT: -! FOR GFS, THIS ROUTINE COMPUTES HRIZONTAL GRADIENTS OF PS OR LNPS -! USING 2ND-ORDER CENTERED SCHEME ON A LAT-LON GRID -! -! PROGRAM HISTORY LOG: -! 16-05-05 SAJAL KAR REDUCED FROM CALVORT TO ZONAL AND MERIDIONAL -! GRADIENTS OF GIVEN SURFACE PRESSURE PS, OR LNPS -! -! USAGE: CALL CALGRADPS(PS,PSX,PSY) -! INPUT ARGUMENT LIST: -! PS - SURFACE PRESSURE (PA) MASS-POINTS -! -! OUTPUT ARGUMENT LIST: -! PSX - ZONAL GRADIENT OF PS AT MASS-POINTS -! PSY - MERIDIONAL GRADIENT OF PS AT MASS-POINTS -! -! OUTPUT FILES: -! NONE -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! NONE -! LIBRARY: -! COMMON - CTLBLK -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! MACHINE : WCOSS -!$$$ -! - use masks, only: gdlat, gdlon - use params_mod, only: dtr, d00, small, erad - use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, & - jsta, jend, im, jm, jsta_m, jend_m, & - 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 diff --git a/sorc/ncep_post.fd/CMakeLists.txt b/sorc/ncep_post.fd/CMakeLists.txt index b97dd6964..b0c556750 100644 --- a/sorc/ncep_post.fd/CMakeLists.txt +++ b/sorc/ncep_post.fd/CMakeLists.txt @@ -26,7 +26,6 @@ list(APPEND LIB_SRC CALVESSEL.f CALVIS.f CALVIS_GSD.f - CALVOR.f CALWXT_BOURG.f CALWXT_DOMINANT.f CALWXT_EXPLICIT.f diff --git a/sorc/ncep_post.fd/CTLBLK.f b/sorc/ncep_post.fd/CTLBLK.f index 2421a07dd..5ca6a0f60 100644 --- a/sorc/ncep_post.fd/CTLBLK.f +++ b/sorc/ncep_post.fd/CTLBLK.f @@ -58,19 +58,22 @@ module CTLBLK_mod 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), & + 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/INITPOST_GFS_NEMS_MPIIO.f b/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f index 33807f269..50c3d4a64 100644 --- a/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f +++ b/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f @@ -97,7 +97,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) dxval, dyval, truelat2, truelat1, psmapf, cenlat use rqstfld_mod, only: igds, avbl, iq, is use nemsio_module_mpi - use upp_physics, only: fpvsnew + use upp_physics, only: fpvsnew, caldiv, calgradps !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! diff --git a/sorc/ncep_post.fd/MDL2P.f b/sorc/ncep_post.fd/MDL2P.f index 3d809e18e..0a5b396e2 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -88,7 +88,7 @@ SUBROUTINE MDL2P(iostatusD3D) 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 diff --git a/sorc/ncep_post.fd/MDL2STD_P.f b/sorc/ncep_post.fd/MDL2STD_P.f index 9d28d60bb..2eabd0c3e 100644 --- a/sorc/ncep_post.fd/MDL2STD_P.f +++ b/sorc/ncep_post.fd/MDL2STD_P.f @@ -49,7 +49,7 @@ SUBROUTINE MDL2STD_P() 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 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! diff --git a/sorc/ncep_post.fd/MDLFLD.f b/sorc/ncep_post.fd/MDLFLD.f index f4d83de71..f865639d9 100644 --- a/sorc/ncep_post.fd/MDLFLD.f +++ b/sorc/ncep_post.fd/MDLFLD.f @@ -102,7 +102,7 @@ SUBROUTINE MDLFLD 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 ! diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 91d73bf52..12f97d266 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -84,16 +84,18 @@ SUBROUTINE MPI_FIRST() use soil, only: smc, stc, sh2o, sldpth, rtdpth, sllevel use masks, only: htm, vtm, hbm2, sm, sice, lmh, gdlat, gdlon, dx, dy, lmv use ctlblk_mod, only: me, num_procs, jm, jsta, jend, jsta_m, jsta_m2,ista,iend , & - jend_m, jend_m2, iup, idn, icnt, im, idsp, jsta_2l, jend_2u, & + jend_m, jend_m2, iup, idn, icnt, im, idsp, jsta_2l, jend_2u,idsp2,icnt2, & jvend_2u, lm, lp1, jsta_2l, jend_2u, nsoil, nbin_du, nbin_ss, & nbin_bc, nbin_oc, nbin_su, & ISTA_M,IEND_M,ISTA_M2,IEND_M2, & iSTA_M,IEND_M,ISTA_M2,IEND_M2, & - ileft,iright, & + ileft,iright,ileftb,irightb , & ibsize,ibsum, & isxa,iexa,jsxa,jexa, & icoords,ibcoords,bufs,ibufs, & ! GWV TMP - ISTA_2L, IEND_2U,IVEND_2U ,numx + rbufs , & ! GWV TMP + rcoords,rbcoords, & ! GWV TMP + ISTA_2L, IEND_2U,IVEND_2U ,numx ! ! use params_mod @@ -104,12 +106,19 @@ SUBROUTINE MPI_FIRST() include 'mpif.h' ! integer ierr,i,jsx,jex,isx,iex,j - integer isumm,isum ,ii,jj + integer size,ubound,lbound + integer isumm,isum ,ii,jj,isumm2 ! integer numx !number of subdomain in x direction integer , allocatable :: ibuff(:) + real , allocatable :: rbuff(:) + integer, allocatable :: ipole(:),ipoles(:,:) + real , allocatable :: rpole(:),rpoles(:,:) +! integer ipoles(im,2),ipole(isx:iex) +! integer numx !number of subdomain in x direction ! isumm=0 + isumm2=0 ! numx=1 ! numx=1 @@ -210,12 +219,19 @@ SUBROUTINE MPI_FIRST() ! ! 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. +! 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 + 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 GWV COORDS test @@ -237,10 +253,18 @@ SUBROUTINE MPI_FIRST() 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) if ( me == 0 ) then - print *, ' i, icnt(i),idsp(i) = ',i,icnt(i), & - idsp(i) + print 196, ' GWVXX i, icnt(i),idsp(i) = ',i,icnt(i), & + idsp(i),icnt2(i),idsp2(i) end if + 196 format(a36,15i10) !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 @@ -250,6 +274,7 @@ SUBROUTINE MPI_FIRST() 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 @@ -276,16 +301,24 @@ SUBROUTINE MPI_FIRST() 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,numx) .eq. 0) Print *,' GWVX ILEFTB ',ileftb,me,numx 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(mod(me+1,numx) .eq. 0 .or. me .eq. num_procs-1) print *,' GWVX IRIGHTB',irightb,me,numx 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) ! !GWV reshape the receive subdomain @@ -293,6 +326,7 @@ SUBROUTINE MPI_FIRST() 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 @@ -310,6 +344,59 @@ SUBROUTINE MPI_FIRST() endif end do end do + allocate(ipoles(im,2),ipole(ista:iend)) + allocate(rpoles(im,2),rpole(ista:iend)) + write (0,196) ' GWVX ISX IEX bounds',ista,iend,me,lbound(ipole),ubound(ipole) + ipole=9900000 + ipoles=-999999999 + + do i=ista,iend +!`k do i=ista_2l,iend_2u +!!gwv if(me .lt. num_procs/2. .and. jsx .eq. 1 .or. me .gt. num_procs/2. & +!! .and. jex .eq. jm) write(0,196)' GWVXX bound',i,isx,iex,jm,9999,lbound(ibcoords),9999,ubound(ibcoords),9999,size(ipole) + 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) +!gwv if(me .lt. num_procs/2. .and. jsta_2l .le. 1 .and. icnt2(me) .gt. 0) print *,' GWVX ISET ',ipole(i),i,1,me + 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) +!gwv if(me .gt. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt. 0) print *,' GWVX ISET ',ipole(i),i,jm,me +! check code to be removed upon debugging + if(me .lt. num_procs/2. .and. jsx .eq. 1) then +!gwv if(i .lt. ista_2l) write(0,*) ' GWVXY I low ',i,999,lbound(ibcoords) +!gwv if(i .gt. iend_2u) write(0,*) ' GWVXY I high ',i,999,ubound(ibcoords) + continue + endif + if(me .gt. num_procs/2. .and. jend_2u .ge. jm) then +!gwv if(1 .lt. jsta_2l .and. me .lt. num_procs/2.) write(0,*) ' GWVXY J LOW ',jsta_2l,1 +! gwv if(jm .gt. jend_2u) write(0,*) ' GWVXY J HI ',jend_2u,jm + continue + endif +!end check code + end do +! test pole gather + print 105,' GWVX GATHER DISP ',icnt2(me),idsp2(me),me + 105 format(a30,3i12) + do i=0,num_procs-1 + if(me .eq. 0) print *,' GWVX IDSP2,icnt2',idsp2(i),icnt2(i) + end do + 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(me .eq. 0) print 107,' GWVX IPOLES,i,j,ii,jj',i,j,ii,jj,ifix(rpoles(i,j)) + if(ii .ne. i .or. jj .ne. 1 .and. jj .ne. jm ) then + write(0,169)' GWVX IPOLES BAD POINT',rpoles(i,j),ii,i,jj,' jm= ',jm + else + write(0,169)' GWVX IPOLES GOOD POINT',rpoles(i,j),ii,i,jj,' jm= ',jm + endif + 107 format(a20,10i10) + 169 format(a25,f20.1,3i10,a10,4i10) + end do + end do + endif ! @@ -322,3 +409,48 @@ SUBROUTINE MPI_FIRST() 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, & ! GWV TMP + + 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 !GWV + integer ifirst + data ifirst/0/ + integer iwest,ieast + data iwest,ieast/0,0/ + allocate(rpole(ista:iend)) !GWV + 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 .gt. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt.0) rpole(i)=a(i,jm) + + end do + call mpi_gatherv(rpole(ista),icnt2(me),MPI_REAL ,rpoles,icnt2,idsp2,MPI_REAL ,0,MPI_COMM_WORLD, ierr ) + ! call mpi_allgatherv(rpole(ista),icnt2(me),MPI_REAL ,rpoles,icnt2,idsp2,MPI_REAL ,MPI_COMM_WORLD, ierr ) + if(me .eq. 0) print *,' GWVX GATHERED POLES ', ierr + call mpi_bcast(rpoles,im*2,MPI_REAL,0,MPI_COMM_WORLD, ierr ) + if(me .eq. 0) print *,' JESSE BCAST POLES ', ierr + + call mpi_barrier(mpi_comm_comp,ierr) + ifirst=1 + + end + diff --git a/sorc/ncep_post.fd/UPP_PHYSICS.f b/sorc/ncep_post.fd/UPP_PHYSICS.f index d87c908e3..fe3699ffb 100644 --- a/sorc/ncep_post.fd/UPP_PHYSICS.f +++ b/sorc/ncep_post.fd/UPP_PHYSICS.f @@ -39,9 +39,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 @@ -1788,5 +1792,999 @@ elemental function TVIRTUAL(T,Q) end function TVIRTUAL ! !------------------------------------------------------------------------------------- +! +! +!------------------------------------------------------------------------------------- +! + +!> @file +! +!> SUBPROGRAM: CALVOR COMPUTES ABSOLUTE VORTICITY +!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 +!! +!! ABSTRACT: +!! THIS ROUTINE COMPUTES THE ABSOLUTE VORTICITY. +!! +!! PROGRAM HISTORY LOG: +!! 92-12-22 RUSS TREADON +!! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D +!! 00-01-04 JIM TUCCILLO - MPI VERSION +!! 02-01-15 MIKE BALDWIN - WRF VERSION C-GRID +!! 05-03-01 H CHUANG - ADD NMM E GRID +!! 05-05-17 H CHUANG - ADD POTENTIAL VORTICITY CALCULATION +!! 05-07-07 B ZHOU - ADD RSM IN COMPUTING DVDX, DUDY AND UAVG +!! 13-08-09 S MOORTHI - Optimize the vorticity loop including threading +!! 16-08-05 S Moorthi - add zonal filetering +!! 2019-10-17 Y Mao - Skip calculation when U/V is SPVAL +!! 2020-11-06 J Meng - USE UPP_MATH MODULE +!! 21-09-02 Bo Cui - Decompose UPP in X direction, REPLACE EXCH_F to EXCH +!! 21-10-31 J MENG - 2D DECOMPOSITION +!! +!! USAGE: CALL CALVOR(UWND,VWND,ABSV) +!! INPUT ARGUMENT LIST: +!! UWND - U WIND (M/S) MASS-POINTS +!! VWND - V WIND (M/S) MASS-POINTS +!! +!! OUTPUT ARGUMENT LIST: +!! ABSV - ABSOLUTE VORTICITY (1/S) MASS-POINTS +!! +!! OUTPUT FILES: +!! NONE +!! +!! SUBPROGRAMS CALLED: +!! UTILITIES: +!! NONE +!! LIBRARY: +!! COMMON - CTLBLK +!! +!! ATTRIBUTES: +!! LANGUAGE: FORTRAN +!! MACHINE : WCOSS +!! + SUBROUTINE CALVOR(UWND,VWND,ABSV) + +! +! + use vrbls2d, only: f + use masks, only: gdlat, gdlon, dx, dy + use params_mod, only: d00, dtr, small, erad + use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, & + jsta, jend, im, jm, jsta_m, jend_m, gdsdegr,& + 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 glatpoles(im,2), coslpoles(im,2), upoles(im,2), avpoles(im,2) + REAL cosltemp(im,jsta_2l:jend_2u), avtemp(im,jsta_2l:jend_2u) +! + 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 + cosltemp(1:im, 1)=coslpoles(1:im,1) + cosltemp(1:im,jm)=coslpoles(1:im,2) + avtemp=spval + avtemp(1:im, 1)=avpoles(1:im,1) + 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)= 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 + + 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)) + +!$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) & + & + 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) & + & + 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) + 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) + 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)) +!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) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . +! SUBPROGRAM: CALGRADPS COMPUTES GRADIENTS OF A SCALAR FIELD PS OR LNPS +! PRGRMMR: SAJAL KAR ORG: W/NP2 DATE: 16-05-05 +! +! ABSTRACT: +! FOR GFS, THIS ROUTINE COMPUTES HRIZONTAL GRADIENTS OF PS OR LNPS +! USING 2ND-ORDER CENTERED SCHEME ON A LAT-LON GRID +! +! PROGRAM HISTORY LOG: +! 16-05-05 SAJAL KAR REDUCED FROM CALVORT TO ZONAL AND MERIDIONAL +! GRADIENTS OF GIVEN SURFACE PRESSURE PS, OR LNPS +! +! USAGE: CALL CALGRADPS(PS,PSX,PSY) +! INPUT ARGUMENT LIST: +! PS - SURFACE PRESSURE (PA) MASS-POINTS +! +! OUTPUT ARGUMENT LIST: +! PSX - ZONAL GRADIENT OF PS AT MASS-POINTS +! PSY - MERIDIONAL GRADIENT OF PS AT MASS-POINTS +! +! OUTPUT FILES: +! NONE +! +! SUBPROGRAMS CALLED: +! UTILITIES: +! NONE +! LIBRARY: +! COMMON - CTLBLK +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN +! MACHINE : WCOSS +!$$$ +! + use masks, only: gdlat, gdlon + use params_mod, only: dtr, d00, small, erad + use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, & + jsta, jend, im, jm, jsta_m, jend_m, & + 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/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f index 7540060f5..929a44c60 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -326,6 +326,12 @@ PROGRAM WRFPOST print*,'numx= ',numx endif + IF(TRIM(IOFORM) /= 'netcdfpara') THEN + numx=1 + if(me == 0) print*,'2D decomposition only supports netcdfpara IO.' + if(me == 0) print*,'Reset numx= ',numx + ENDIF + ! set up pressure level from POSTGPVARS or DEFAULT if(kpo == 0) then ! use default pressure levels @@ -391,7 +397,7 @@ PROGRAM WRFPOST PTHRESH = 0.000001 end if !Chuang: add dynamical allocation - if(TRIM(IOFORM) == 'netcdf') THEN + IF(TRIM(IOFORM) == 'netcdf') THEN IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR' .OR. MODELNAME == 'NMM') THEN call ext_ncd_ioinit(SysDepInfo,Status) print*,'called ioinit', Status diff --git a/sorc/ncep_post.fd/makefile_module b/sorc/ncep_post.fd/makefile_module index 42446e4c2..f8acb5a64 100644 --- a/sorc/ncep_post.fd/makefile_module +++ b/sorc/ncep_post.fd/makefile_module @@ -75,7 +75,8 @@ OBJS = wrf_io_flags.o getVariable.o getIVariableN.o \ UPP_MATH.o UPP_PHYSICS.o \ BNDLYR.o BOUND.o CALDWP.o CALDRG.o CALHEL.o CALLCL.o \ CALMCVG.o CALPOT.o CALPW.o CALRCH.o \ - CALSTRM.o CALTAU.o CALTHTE.o CALVIS.o CALVIS_GSD.o CALVOR.o CALWXT.o \ +# CALSTRM.o CALTAU.o CALTHTE.o CALVIS.o CALVIS_GSD.o CALVOR.o CALWXT.o + CALSTRM.o CALTAU.o CALTHTE.o CALVIS.o CALVIS_GSD.o CALWXT.o \ CALWXT_RAMER.o CALWXT_BOURG.o CALWXT_REVISED.o \ CALWXT_EXPLICIT.o CALWXT_DOMINANT.o \ CLDRAD.o CLMAX.o COLLECT.o COLLECT_LOC.o DEWPOINT.o \ diff --git a/ush/gfs_nceppost.sh b/ush/gfs_nceppost.sh index 9e9fefb6e..eccd19161 100755 --- a/ush/gfs_nceppost.sh +++ b/ush/gfs_nceppost.sh @@ -292,7 +292,7 @@ export pgm=$PGM $LOGSCRIPT cat <postgp.inp.nml$$ &NAMPGB - $POSTGPVARS numx=1, + $POSTGPVARS numx=1 EOF cat <>postgp.inp.nml$$ From 74d5f84743811dc1deafb093bffc23153573225c Mon Sep 17 00:00:00 2001 From: wx22mj Date: Thu, 2 Dec 2021 18:50:58 +0000 Subject: [PATCH 50/77] 20211202 Jesse Meng minor update of MPI_FIRST using mpi_allgatherv --- sorc/ncep_post.fd/MPI_FIRST.f | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 12f97d266..14e08987e 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -443,11 +443,12 @@ subroutine fullpole(a,rpoles) if(me .gt. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt.0) rpole(i)=a(i,jm) end do - call mpi_gatherv(rpole(ista),icnt2(me),MPI_REAL ,rpoles,icnt2,idsp2,MPI_REAL ,0,MPI_COMM_WORLD, ierr ) - ! call mpi_allgatherv(rpole(ista),icnt2(me),MPI_REAL ,rpoles,icnt2,idsp2,MPI_REAL ,MPI_COMM_WORLD, ierr ) - if(me .eq. 0) print *,' GWVX GATHERED POLES ', ierr - call mpi_bcast(rpoles,im*2,MPI_REAL,0,MPI_COMM_WORLD, ierr ) - if(me .eq. 0) print *,' JESSE BCAST POLES ', ierr + + call mpi_allgatherv(rpole(ista),icnt2(me),MPI_REAL ,rpoles,icnt2,idsp2,MPI_REAL ,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) print *,' GWVX GATHERED POLES ', ierr + ! call mpi_bcast(rpoles,im*2,MPI_REAL,0,MPI_COMM_WORLD, ierr ) + ! if(me .eq. 0) print *,' JESSE BCAST POLES ', ierr call mpi_barrier(mpi_comm_comp,ierr) ifirst=1 From 8c7bab6a254cfec94089392cd321d66c7cd33349 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Sat, 4 Dec 2021 01:51:04 +0000 Subject: [PATCH 51/77] 20211203 Jesse Meng implement fullpole in MDL2THANDPV and CALDIV --- sorc/ncep_post.fd/MDL2THANDPV.f | 193 ++++++++++++++++++++++++-------- sorc/ncep_post.fd/UPP_PHYSICS.f | 62 +++++++--- 2 files changed, 193 insertions(+), 62 deletions(-) diff --git a/sorc/ncep_post.fd/MDL2THANDPV.f b/sorc/ncep_post.fd/MDL2THANDPV.f index 7b7a41ce1..001cb40e4 100644 --- a/sorc/ncep_post.fd/MDL2THANDPV.f +++ b/sorc/ncep_post.fd/MDL2THANDPV.f @@ -77,8 +77,11 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) real, dimension(ISTA:IEND,JSTA:JEND,KTH) :: UTH, VTH, HMTH, TTH, PVTH, & SIGMATH, RHTH, OTH 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 @@ -163,19 +166,6 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) CALL EXCH(GDLAT(ISTA_2L,JSTA_2L)) CALL EXCH(GDLON(ISTA_2L,JSTA_2L)) - if(me==0) then - write(0,*) 'me,ista_2l,ista,iend,iend_2u' - write(0,*) me,ista_2l,ista,iend,iend_2u - write(0,*) 'me,jsta_2l,jsta,jend,jend_2u' - write(0,*) me,jsta_2l,jsta,jend,jend_2u - write(0,*) 'me,gdlon(ista_2l,jsta),gdlon(ista-1,jsta),gdlon(ista,jsta),gdlon(iend,jsta),gdlon(iend+1,jsta),gdlon(iend_2u,jsta)' - write(0,*) me,gdlon(ista_2l,jsta),gdlon(ista-1,jsta),gdlon(ista,jsta),gdlon(iend,jsta),gdlon(iend+1,jsta),gdlon(iend_2u,jsta) - write(0,*) 'me,vh(ista_2l,jsta,1),vh(ista-1,jsta,1),vh(ista,jsta,1),vh(iend,jsta,1),vh(iend+1,jsta,1),vh(iend_2u,jsta,1)' - write(0,*) me,vh(ista_2l,jsta,1),vh(ista-1,jsta,1),vh(ista,jsta,1),vh(iend,jsta,1),vh(iend+1,jsta,1),vh(iend_2u,jsta,1) - ! write(0,*) 'me,gdlat(ista,jsta_2l),gdlat(ista,jsta),gdlat(iend,jend),gdlat(iend,jend_2u)' - ! write(0,*) me,gdlat(ista,jsta_2l),gdlat(ista,jsta),gdlat(iend,jend),gdlat(iend,jend_2u) - endif - ! print *,' JSTA_2L=',JSTA_2L,' JSTA=',JSTA_2L,' JEND_2U=', & ! &JEND_2U,' JEND=',JEND,' IM=',IM ! print *,' GDLATa=',gdlat(1,:) @@ -183,9 +173,10 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ! 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 - !imb2=0 !JESSE to be discussed for x decomposition eradi = 1.0 / erad !! IF(MODELNAME == 'GFS' .or. global) THEN @@ -195,11 +186,8 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ie(i) = i + 1 iw(i) = i - 1 enddo -!JESSE 2D DECOMPOSITION iw(1) = im ie(im) = 1 - !iw(1) = 1 - !ie(im) = im ! !$omp parallel do private(i,j,ip1,im1) DO J=JSTA,JEND @@ -220,8 +208,10 @@ 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 @@ -229,13 +219,15 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) 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=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) @@ -275,6 +267,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) !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=ISTA,IEND @@ -293,10 +291,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 @@ -328,11 +329,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 @@ -380,7 +384,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 @@ -394,7 +398,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 @@ -473,7 +477,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 @@ -781,12 +785,27 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ! IF(IGET(335) > 0) THEN IF(LVLS(LP,IGET(335)) > 0)THEN -!JESSE TBD - 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=ISTA,IEND @@ -928,8 +947,24 @@ 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=ISTA,IEND @@ -970,8 +1005,24 @@ 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=ISTA,IEND @@ -999,8 +1050,24 @@ 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=ISTA,IEND @@ -1028,8 +1095,24 @@ 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=ISTA,IEND @@ -1057,8 +1140,24 @@ 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=ISTA,IEND @@ -1085,7 +1184,7 @@ 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) write(0,*) 'MDL2THANDPV ends' diff --git a/sorc/ncep_post.fd/UPP_PHYSICS.f b/sorc/ncep_post.fd/UPP_PHYSICS.f index fe3699ffb..e43c2980c 100644 --- a/sorc/ncep_post.fd/UPP_PHYSICS.f +++ b/sorc/ncep_post.fd/UPP_PHYSICS.f @@ -1860,8 +1860,8 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) ! 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 glatpoles(im,2), coslpoles(im,2), upoles(im,2), avpoles(im,2) - REAL cosltemp(im,jsta_2l:jend_2u), avtemp(im,jsta_2l:jend_2u) + 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(:) @@ -2160,11 +2160,11 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) call fullpole(absv(ista_2l:iend_2u,jsta_2l:jend_2u),avpoles) cosltemp=spval - cosltemp(1:im, 1)=coslpoles(1:im,1) - cosltemp(1:im,jm)=coslpoles(1:im,2) + if(jsta== 1) cosltemp(1:im, 1)=coslpoles(1:im,1) + if(jend==jm) cosltemp(1:im,jm)=coslpoles(1:im,2) avtemp=spval - avtemp(1:im, 1)=avpoles(1:im,1) - avtemp(1:im,jm)=avpoles(1:im,2) + 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)) @@ -2303,6 +2303,8 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) ! 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(:) @@ -2352,6 +2354,8 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) 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 @@ -2360,13 +2364,15 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) 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 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)+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 @@ -2374,13 +2380,15 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) 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)+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)-GDLAT(II,J))*DTR) + wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GLATPOLES(II,2))*DTR) enddo end if else @@ -2401,6 +2409,9 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) 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 @@ -2412,7 +2423,8 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) 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(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 !-- @@ -2435,7 +2447,8 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) 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(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 !-- @@ -2460,7 +2473,8 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) 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) + !& ! + 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 @@ -2483,7 +2497,8 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) 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) + !& ! + 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 @@ -2515,7 +2530,24 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) 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 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) From 76d4a5d1482b8f933640162fd80e95b401d7fb2b Mon Sep 17 00:00:00 2001 From: wx22mj Date: Tue, 7 Dec 2021 18:01:27 +0000 Subject: [PATCH 52/77] 20211207 Jesse Meng update MISCLN.f SURFCE.f --- sorc/ncep_post.fd/MISCLN.f | 2 +- sorc/ncep_post.fd/SURFCE.f | 16 ++++++++-------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/sorc/ncep_post.fd/MISCLN.f b/sorc/ncep_post.fd/MISCLN.f index 53bf26843..ec083dffa 100644 --- a/sorc/ncep_post.fd/MISCLN.f +++ b/sorc/ncep_post.fd/MISCLN.f @@ -4174,7 +4174,7 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(987)) fld_info(cfld)%lvl=LVLSXML(1,IGET(987)) -! $omp parallel do private(i,j,jj) +! $omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 do i=1,iend-ista+1 diff --git a/sorc/ncep_post.fd/SURFCE.f b/sorc/ncep_post.fd/SURFCE.f index 13ecada1f..1ceb97141 100644 --- a/sorc/ncep_post.fd/SURFCE.f +++ b/sorc/ncep_post.fd/SURFCE.f @@ -460,7 +460,7 @@ 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,iend-ista+1 @@ -910,7 +910,7 @@ 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,iend-ista+1 @@ -1735,7 +1735,7 @@ 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,iend-ista+1 @@ -1963,7 +1963,7 @@ 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,iend-ista+1 @@ -2331,7 +2331,7 @@ SUBROUTINE SURFCE 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,iend-ista+1 @@ -2604,7 +2604,7 @@ 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,iend-ista+1 @@ -2721,7 +2721,7 @@ 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,iend-ista+1 @@ -6080,7 +6080,7 @@ 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,iend-ista+1 From 278fa2a675a3fed751514e552739c33833b301d8 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Wed, 8 Dec 2021 17:05:35 +0000 Subject: [PATCH 53/77] 20211208 Jesse Meng add parm/hafs_nosat files --- parm/postcntrl_hafs_nosat.xml | 521 ++++++ parm/postxconfig-NT-hafs_nosat.txt | 2682 ++++++++++++++++++++++++++++ 2 files changed, 3203 insertions(+) create mode 100755 parm/postcntrl_hafs_nosat.xml create mode 100644 parm/postxconfig-NT-hafs_nosat.txt diff --git a/parm/postcntrl_hafs_nosat.xml b/parm/postcntrl_hafs_nosat.xml new file mode 100755 index 000000000..12746980c --- /dev/null +++ b/parm/postcntrl_hafs_nosat.xml @@ -0,0 +1,521 @@ + + + + + HURPRS + 32769 + ncep_nco + v2003 + local_tab_yes1 + fcst + oper + fcst + fcst + hour + nws_ncep + hafs + complex_packing_spatial_diff + 2nd_ord_sptdiff + fltng_pnt + lossless + + + HGT_ON_ISOBARIC_SFC + HGT + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 6.0 + + + + TMP_ON_ISOBARIC_SFC + TMP + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 4.0 + + + + SPFH_ON_ISOBARIC_SFC + SPFH + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 7.0 + + + + RH_ON_ISOBARIC_SFC + RH + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 3.0 + + + + UGRD_ON_ISOBARIC_SFC + UGRD + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 4.0 + + + + VGRD_ON_ISOBARIC_SFC + VGRD + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 4.0 + + + + DZDT_ON_ISOBARIC_SFC + DZDT + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 5.0 + + + + VVEL_ON_ISOBARIC_SFC + VVEL + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 5.0 + + + + ABSV_ON_ISOBARIC_SFC + ABSV + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 4.0 + + + + CLWMR_ON_ISOBARIC_SFC + CLWMR + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 6.0 + + + + ICMR_ON_ISOBARIC_SFC + ICMR + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 6.0 + + + + RWMR_ON_ISOBARIC_SFC + RWMR + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 6.0 + + + + SNMR_ON_ISOBARIC_SFC + SNMR + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 6.0 + + + + GRLE_ON_ISOBARIC_SFC + GRLE + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 6.0 + + + + REFD_ON_ISOBARIC_SFC + REFD + 200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. +47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. + 4.0 + + + + MSLET_ON_MEAN_SEA_LVL + MSLET + NCEP + 6.0 + + + + PRES_ON_MEAN_SEA_LVL + PRMSL + 6.0 + + + + TMP_ON_SPEC_HGT_LVL_ABOVE_GRND_2m + TMP + 4.0 + + + + SPFH_ON_SPEC_HGT_LVL_ABOVE_GRND_2m + SPFH + 7.0 + + + + DPT_ON_SPEC_HGT_LVL_ABOVE_GRND_2m + DPT + 4.0 + + + + RH_ON_SPEC_HGT_LVL_ABOVE_GRND_2m + RH + 3.0 + + + + UGRD_ON_SPEC_HGT_LVL_ABOVE_GRND_10m + UGRD + 10. + 4.0 + + + + VGRD_ON_SPEC_HGT_LVL_ABOVE_GRND_10m + VGRD + 10. + 4.0 + + + + PRES_ON_SURFACE + PRES + 6.0 + + + + HGT_ON_SURFACE + HGT + 6.0 + + + + TMP_ON_SURFACE + TMP + 4.0 + + + + SFEXC_ON_SURFACE + SFEXC + NCEP + 4.0 + + + + CAPE_ON_SURFACE + CAPE + 4.0 + + + + CIN_ON_SURFACE + CIN + 4.0 + + + + PWAT_ON_ENTIRE_ATMOS_SINGLE_LYR + PWAT + 6.0 + + + + HLCY_ON_SPEC_HGT_LVL_ABOVE_GRND + HLCY + 3000. + 4.0 + + + + ACM_APCP_ON_SURFACE + APCP + -4.0 + + + + ACM_NCPCP_ON_SURFACE + NCPCP + -4.0 + + + + INST_PRATE_ON_SURFACE + PRATE + 6.0 + + + + INST_TCDC_ON_ENTIRE_ATMOS + TCDC + 4.0 + + + + AVE_TCDC_ON_ENTIRE_ATMOS + TCDC + 4.0 + + + + INST_USWRF_ON_SURFACE + USWRF + NCEP + 6.0 + + + + INST_ULWRF_ON_SURFACE + ULWRF + NCEP + 6.0 + + + + AVE_DSWRF_ON_SURFACE + DSWRF + NCEP + 6.0 + + + + AVE_DLWRF_ON_SURFACE + DLWRF + NCEP + 4.0 + + + + AVE_USWRF_ON_SURFACE + USWRF + NCEP + 6.0 + + + + AVE_ULWRF_ON_SURFACE + ULWRF + NCEP + 4.0 + + + + AVE_USWRF_ON_TOP_OF_ATMOS + USWRF + NCEP + 6.0 + + + + AVE_ULWRF_ON_TOP_OF_ATMOS + ULWRF + NCEP + 4.0 + + + + INST_ULWRF_ON_TOP_OF_ATMOS + ULWRF + NCEP + 4.0 + + + + INST_DSWRF_ON_SURFACE + DSWRF + NCEP + 6.0 + + + + INST_DLWRF_ON_SURFACE + DLWRF + NCEP + 4.0 + + + + SFCR_ON_SURFACE + SFCR + 6.0 + + + + FRICV_ON_SURFACE + FRICV + NCEP + 4.0 + + + + UFLX_ON_SURFACE + UFLX + 4.0 + + + + VFLX_ON_SURFACE + VFLX + 4.0 + + + + INST_SHTFL_ON_SURFACE + SHTFL + 4.0 + + + + INST_LHTFL_ON_SURFACE + LHTFL + 4.0 + + + + NLAT_ON_SURFACE + NLAT + NCEP + 4.0 + + + + ELON_ON_SURFACE + ELON + NCEP + 4.0 + + + + LAND_ON_SURFACE + LAND + 1.0 + + + + WTMP_ON_SURFACE + WTMP + 4.0 + + + + PRES_ON_TROPOPAUSE + PRES + 6.0 + + + + HGT_ON_TROPOPAUSE + HGT + 6.0 + + + + TMP_ON_TROPOPAUSE + TMP + 4.0 + + + + UGRD_ON_TROPOPAUSE + UGRD + 4.0 + + + + VGRD_ON_TROPOPAUSE + VGRD + 4.0 + + + + VWSH_ON_TROPOPAUSE + VWSH + NCEP + 3.0 + + + + TMP_ON_CLOUD_TOP + TMP + 4.0 + + + + REFC_ON_ENTIRE_ATMOS + REFC + NCEP + 4.0 + + + + HPBL_ON_SURFACE + HPBL + NCEP + 6.0 + + + + TCOLW_ON_ENTIRE_ATMOS + TCOLW + NCEP + 5.0 + + + + TCOLI_ON_ENTIRE_ATMOS + TCOLI + NCEP + 5.0 + + + + TCOLR_ON_ENTIRE_ATMOS + TCOLR + NCEP + 5.0 + + + + TCOLS_ON_ENTIRE_ATMOS + TCOLS + NCEP + 5.0 + + + + TCOLC_ON_ENTIRE_ATMOS + TCOLC + NCEP + 5.0 + + + + MAX_PRATE_ON_SURFACE + PRATE + 6.0 + + + + MAX_WIND_ON_SPEC_HGT_LVL_ABOVE_GRND_10m + WIND + -4.0 + + + + + + + diff --git a/parm/postxconfig-NT-hafs_nosat.txt b/parm/postxconfig-NT-hafs_nosat.txt new file mode 100644 index 000000000..9a330bb20 --- /dev/null +++ b/parm/postxconfig-NT-hafs_nosat.txt @@ -0,0 +1,2682 @@ +1 +72 +HURPRS +32769 +ncep_nco +v2003 +local_tab_yes1 +fcst +oper +fcst +fcst +hour +nws_ncep +hafs +complex_packing_spatial_diff +2nd_ord_sptdiff +fltng_pnt +lossless +12 +HGT_ON_ISOBARIC_SFC +? +1 +tmpl4_0 +HGT +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +13 +TMP_ON_ISOBARIC_SFC +? +1 +tmpl4_0 +TMP +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +16 +SPFH_ON_ISOBARIC_SFC +? +1 +tmpl4_0 +SPFH +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +7.0 +0 +0 +0 +? +? +? +17 +RH_ON_ISOBARIC_SFC +? +1 +tmpl4_0 +RH +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +3.0 +0 +0 +0 +? +? +? +18 +UGRD_ON_ISOBARIC_SFC +? +1 +tmpl4_0 +UGRD +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +19 +VGRD_ON_ISOBARIC_SFC +? +1 +tmpl4_0 +VGRD +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +284 +DZDT_ON_ISOBARIC_SFC +? +1 +tmpl4_0 +DZDT +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +5.0 +0 +0 +0 +? +? +? +20 +VVEL_ON_ISOBARIC_SFC +? +1 +tmpl4_0 +VVEL +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +5.0 +0 +0 +0 +? +? +? +21 +ABSV_ON_ISOBARIC_SFC +? +1 +tmpl4_0 +ABSV +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +166 +ICMR_ON_ISOBARIC_SFC +? +1 +tmpl4_0 +ICMR +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +183 +RWMR_ON_ISOBARIC_SFC +? +1 +tmpl4_0 +RWMR +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +184 +SNMR_ON_ISOBARIC_SFC +? +1 +tmpl4_0 +SNMR +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +416 +GRLE_ON_ISOBARIC_SFC +Graupel mixing ration on isobaric surface +1 +tmpl4_0 +GRLE +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +251 +REFD_ON_ISOBARIC_SFC +? +1 +tmpl4_0 +REFD +? +? +isobaric_sfc +0 +? +45 +200. 500. 700. 1000. 2000. 3000. 5000. 7000. 10000. 12500. 15000. 17500. 20000. 22500. 25000. 27500. 30000. 32500. 35000. 37500. 40000. 42500. 45000. 47500. 50000. 52500. 55000. 57500. 60000. 62500. 65000. 67500. 70000. 72500. 75000. 77500. 80000. 82500. 85000. 87500. 90000. 92500. 95000. 97500. 100000. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +23 +MSLET_ON_MEAN_SEA_LVL +? +1 +tmpl4_0 +MSLET +NCEP +? +mean_sea_lvl +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +105 +PRES_ON_MEAN_SEA_LVL +? +1 +tmpl4_0 +PRMSL +? +? +mean_sea_lvl +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +106 +TMP_ON_SPEC_HGT_LVL_ABOVE_GRND_2m +? +1 +tmpl4_0 +TMP +? +? +spec_hgt_lvl_above_grnd +0 +? +1 +2. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +112 +SPFH_ON_SPEC_HGT_LVL_ABOVE_GRND_2m +? +1 +tmpl4_0 +SPFH +? +? +spec_hgt_lvl_above_grnd +0 +? +1 +2. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +7.0 +0 +0 +0 +? +? +? +113 +DPT_ON_SPEC_HGT_LVL_ABOVE_GRND_2m +? +1 +tmpl4_0 +DPT +? +? +spec_hgt_lvl_above_grnd +0 +? +1 +2. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +114 +RH_ON_SPEC_HGT_LVL_ABOVE_GRND_2m +? +1 +tmpl4_0 +RH +? +? +spec_hgt_lvl_above_grnd +0 +? +1 +2. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +3.0 +0 +0 +0 +? +? +? +64 +UGRD_ON_SPEC_HGT_LVL_ABOVE_GRND_10m +? +1 +tmpl4_0 +UGRD +? +? +spec_hgt_lvl_above_grnd +0 +? +1 +10. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +65 +VGRD_ON_SPEC_HGT_LVL_ABOVE_GRND_10m +? +1 +tmpl4_0 +VGRD +? +? +spec_hgt_lvl_above_grnd +0 +? +1 +10. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +24 +PRES_ON_SURFACE +? +1 +tmpl4_0 +PRES +? +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +25 +HGT_ON_SURFACE +? +1 +tmpl4_0 +HGT +? +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +26 +TMP_ON_SURFACE +? +1 +tmpl4_0 +TMP +? +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +169 +SFEXC_ON_SURFACE +? +1 +tmpl4_0 +SFEXC +NCEP +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +32 +CAPE_ON_SURFACE +? +1 +tmpl4_0 +CAPE +? +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +107 +CIN_ON_SURFACE +? +1 +tmpl4_0 +CIN +? +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +80 +PWAT_ON_ENTIRE_ATMOS_SINGLE_LYR +? +1 +tmpl4_0 +PWAT +? +? +entire_atmos_single_lyr +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +162 +HLCY_ON_SPEC_HGT_LVL_ABOVE_GRND +? +1 +tmpl4_0 +HLCY +? +? +spec_hgt_lvl_above_grnd +0 +? +1 +3000. +spec_hgt_lvl_above_grnd +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +87 +ACM_APCP_ON_SURFACE +? +1 +tmpl4_8 +APCP +? +ACM +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +-4.0 +0 +0 +0 +? +? +? +34 +ACM_NCPCP_ON_SURFACE +? +1 +tmpl4_8 +NCPCP +? +ACM +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +-4.0 +0 +0 +0 +? +? +? +167 +INST_PRATE_ON_SURFACE +? +1 +tmpl4_0 +PRATE +? +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +161 +INST_TCDC_ON_ENTIRE_ATMOS +? +1 +tmpl4_0 +TCDC +? +? +entire_atmos_single_lyr +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +144 +AVE_TCDC_ON_ENTIRE_ATMOS +? +1 +tmpl4_8 +TCDC +? +AVE +entire_atmos_single_lyr +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +141 +INST_USWRF_ON_SURFACE +? +1 +tmpl4_0 +USWRF +NCEP +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +142 +INST_ULWRF_ON_SURFACE +? +1 +tmpl4_0 +ULWRF +NCEP +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +126 +AVE_DSWRF_ON_SURFACE +? +1 +tmpl4_8 +DSWRF +NCEP +AVE +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +127 +AVE_DLWRF_ON_SURFACE +? +1 +tmpl4_8 +DLWRF +NCEP +AVE +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +128 +AVE_USWRF_ON_SURFACE +? +1 +tmpl4_8 +USWRF +NCEP +AVE +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +129 +AVE_ULWRF_ON_SURFACE +? +1 +tmpl4_8 +ULWRF +NCEP +AVE +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +130 +AVE_USWRF_ON_TOP_OF_ATMOS +? +1 +tmpl4_8 +USWRF +NCEP +AVE +top_of_atmos +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +131 +AVE_ULWRF_ON_TOP_OF_ATMOS +? +1 +tmpl4_8 +ULWRF +NCEP +AVE +top_of_atmos +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +274 +INST_ULWRF_ON_TOP_OF_ATMOS +? +1 +tmpl4_0 +ULWRF +NCEP +? +top_of_atmos +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +156 +INST_DSWRF_ON_SURFACE +? +1 +tmpl4_0 +DSWRF +NCEP +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +157 +INST_DLWRF_ON_SURFACE +? +1 +tmpl4_0 +DLWRF +NCEP +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +44 +SFCR_ON_SURFACE +? +1 +tmpl4_0 +SFCR +? +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +45 +FRICV_ON_SURFACE +? +1 +tmpl4_0 +FRICV +NCEP +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +133 +UFLX_ON_SURFACE +? +1 +tmpl4_0 +UFLX +? +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +134 +VFLX_ON_SURFACE +? +1 +tmpl4_0 +VFLX +? +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +154 +INST_SHTFL_ON_SURFACE +? +1 +tmpl4_0 +SHTFL +? +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +155 +INST_LHTFL_ON_SURFACE +? +1 +tmpl4_0 +LHTFL +? +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +48 +NLAT_ON_SURFACE +? +1 +tmpl4_0 +NLAT +NCEP +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +49 +ELON_ON_SURFACE +? +1 +tmpl4_0 +ELON +NCEP +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +50 +LAND_ON_SURFACE +? +1 +tmpl4_0 +LAND +? +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +1.0 +0 +0 +0 +? +? +? +151 +WTMP_ON_SURFACE +? +1 +tmpl4_0 +WTMP +? +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +54 +PRES_ON_TROPOPAUSE +? +1 +tmpl4_0 +PRES +? +? +tropopause +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +177 +HGT_ON_TROPOPAUSE +? +1 +tmpl4_0 +HGT +? +? +tropopause +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +55 +TMP_ON_TROPOPAUSE +? +1 +tmpl4_0 +TMP +? +? +tropopause +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +56 +UGRD_ON_TROPOPAUSE +? +1 +tmpl4_0 +UGRD +? +? +tropopause +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +57 +VGRD_ON_TROPOPAUSE +? +1 +tmpl4_0 +VGRD +? +? +tropopause +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +58 +VWSH_ON_TROPOPAUSE +? +1 +tmpl4_0 +VWSH +NCEP +? +tropopause +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +3.0 +0 +0 +0 +? +? +? +168 +TMP_ON_CLOUD_TOP +? +1 +tmpl4_0 +TMP +? +? +cloud_top +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +252 +REFC_ON_ENTIRE_ATMOS +? +1 +tmpl4_0 +REFC +NCEP +? +entire_atmos_single_lyr +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +4.0 +0 +0 +0 +? +? +? +221 +HPBL_ON_SURFACE +? +1 +tmpl4_0 +HPBL +NCEP +? +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +200 +TCOLW_ON_ENTIRE_ATMOS +? +1 +tmpl4_0 +TCOLW +NCEP +? +entire_atmos_single_lyr +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +5.0 +0 +0 +0 +? +? +? +201 +TCOLI_ON_ENTIRE_ATMOS +? +1 +tmpl4_0 +TCOLI +NCEP +? +entire_atmos_single_lyr +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +5.0 +0 +0 +0 +? +? +? +202 +TCOLR_ON_ENTIRE_ATMOS +? +1 +tmpl4_0 +TCOLR +NCEP +? +entire_atmos_single_lyr +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +5.0 +0 +0 +0 +? +? +? +203 +TCOLS_ON_ENTIRE_ATMOS +? +1 +tmpl4_0 +TCOLS +NCEP +? +entire_atmos_single_lyr +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +5.0 +0 +0 +0 +? +? +? +204 +TCOLC_ON_ENTIRE_ATMOS +? +1 +tmpl4_0 +TCOLC +NCEP +? +entire_atmos_single_lyr +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +5.0 +0 +0 +0 +? +? +? +508 +MAX_PRATE_ON_SURFACE +Maximum Precipitation Rate on surface +1 +tmpl4_8 +PRATE +? +MAX +surface +0 +? +0 +? +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +6.0 +0 +0 +0 +? +? +? +422 +MAX_WIND_ON_SPEC_HGT_LVL_ABOVE_GRND_10m +maximum wind speed on 10 meter Above Ground +1 +tmpl4_8 +WIND +? +MAX +spec_hgt_lvl_above_grnd +0 +? +1 +10. +? +0 +? +0 +? +? +? +0 +0.0 +0 +0.0 +? +0 +0.0 +0 +0.0 +1 +-4.0 +0 +0 +0 +? +? +? From 9d4c3fad44f9201c7906281d85d8b30c53ce5cc5 Mon Sep 17 00:00:00 2001 From: Bo Cui Date: Mon, 13 Dec 2021 13:11:46 -0500 Subject: [PATCH 54/77] 20211213 Bo Cui updates for 2D decomposition --- sorc/ncep_post.fd/CALMCVG.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sorc/ncep_post.fd/CALMCVG.f b/sorc/ncep_post.fd/CALMCVG.f index fa726809f..b354052d6 100644 --- a/sorc/ncep_post.fd/CALMCVG.f +++ b/sorc/ncep_post.fd/CALMCVG.f @@ -152,7 +152,7 @@ SUBROUTINE CALMCVG(Q1D,U1D,V1D,QCNVG) DO J=JSTA_M2,JEND_M2 ! IEND = IM-1-MOD(J,2) ! DO I=2,IEND - DO I=ISTA_M2,IEND_M2 + DO I=ISTA_M,IEND_M-MOD(J,2) IF(QV(I+IHE(J),J) Date: Tue, 14 Dec 2021 00:53:50 +0000 Subject: [PATCH 55/77] 20211213 Jesse Meng update the merged 'upstream/develop' and 'post_2d_decomp' branch to 2d_decomp style --- sorc/ncep_post.fd/FIXED.f | 4 ++-- sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f | 2 +- sorc/ncep_post.fd/SURFCE.f | 14 ++++++++------ 3 files changed, 11 insertions(+), 9 deletions(-) diff --git a/sorc/ncep_post.fd/FIXED.f b/sorc/ncep_post.fd/FIXED.f index a3c8bc716..80a9d2fde 100644 --- a/sorc/ncep_post.fd/FIXED.f +++ b/sorc/ncep_post.fd/FIXED.f @@ -342,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 diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f index b969f62aa..74f71f4c8 100644 --- a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f +++ b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f @@ -1028,7 +1028,7 @@ SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) ! foundation temperature VarName='tref' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & + call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & spval,VarName,fdnsst) if(debugprint)print*,'sample ',VarName,' = ',fdnsst(isa,jsa) diff --git a/sorc/ncep_post.fd/SURFCE.f b/sorc/ncep_post.fd/SURFCE.f index 16c608e33..d17ec2224 100644 --- a/sorc/ncep_post.fd/SURFCE.f +++ b/sorc/ncep_post.fd/SURFCE.f @@ -6446,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 @@ -6465,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) @@ -6508,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 @@ -6560,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 From 49d4680b207ffedfb760dcaa489f317da7e84f69 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Wed, 15 Dec 2021 19:35:45 +0000 Subject: [PATCH 56/77] 20211215 Jesse Meng use i=0:im+1 for GFS in MPI_FIRST and EXCH --- sorc/ncep_post.fd/EXCH.f | 142 +++++++++++++++++++++++++------- sorc/ncep_post.fd/MDL2THANDPV.f | 4 +- sorc/ncep_post.fd/MPI_FIRST.f | 19 +++-- sorc/ncep_post.fd/UPP_PHYSICS.f | 8 +- 4 files changed, 130 insertions(+), 43 deletions(-) diff --git a/sorc/ncep_post.fd/EXCH.f b/sorc/ncep_post.fd/EXCH.f index 6f9b4f852..8dd78522b 100644 --- a/sorc/ncep_post.fd/EXCH.f +++ b/sorc/ncep_post.fd/EXCH.f @@ -37,9 +37,9 @@ SUBROUTINE EXCH(A) use ctlblk_mod, only: num_procs, jend, iup, jsta, idn, mpi_comm_comp, im,& - icoords,ibcoords,bufs,ibufs,me, & ! GWV TMP + icoords,ibcoords,bufs,ibufs,me,numx, & ! GWV TMP - jsta_2l, jend_2u,ileft,iright,ista_2l,iend_2u,ista,iend,jm + jsta_2l, jend_2u,ileft,iright,ista_2l,iend_2u,ista,iend,jm,modelname !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -49,6 +49,7 @@ SUBROUTINE EXCH(A) real,intent(inout) :: a ( ista_2l:iend_2u,jsta_2l:jend_2u ) real, allocatable :: coll(:), colr(:) integer, allocatable :: icoll(:), icolr(:) + real, allocatable :: rpole(:),rpoles(:,:) integer status(MPI_STATUS_SIZE) @@ -56,10 +57,13 @@ SUBROUTINE EXCH(A) integer size,ubound,lbound integer msglenl, msglenr integer i,ii,jj, ibl,ibu,jbl,jbu,icc,jcc !GWV + integer iwest,ieast allocate(coll(jm)) allocate(colr(jm)) allocate(icolr(jm)) !GWV allocate(icoll(jm)) !GWV + allocate(rpole(ista:iend)) !GWV + allocate(rpoles(im,2)) !GWV ibl=max(ista-1,1) ibu=min(im,iend+1) jbu=min(jm,jend+1) @@ -71,14 +75,32 @@ SUBROUTINE EXCH(A) ! jsta,'idn=',idn if ( num_procs <= 1 ) return ! +! for global model apply cyclic boundary condition + + IF(MODELNAME == 'GFS') then + print *,' GWVX 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) !GWVB + if(iright .eq. MPI_PROC_NULL) iright=(me-numx) +1 !GWVB + endif + jstam1 = max(jsta_2l,jsta-1) ! Moorthi ! 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) + if ( ierr /= 0 ) then + print *, ' problem with second sendrecv in exch, ierr = ',ierr + stop + endif 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 + endif do i=ista,iend ii=ibcoords(i,jstam1)/10000 jj=ibcoords(i,jstam1)-(ii*10000) @@ -101,19 +123,27 @@ SUBROUTINE EXCH(A) 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 second sendrecv in exch, ierr = ',ierr + stop + endif call mpi_sendrecv(icoll(jsta),msglenl ,MPI_INTEGER,ileft,1, & !GWV TMP & icolr(jsta),msglenr ,MPI_INTEGER,iright,1, & !GWV TMP & MPI_COMM_COMP,status,ierr) - if(iright .gt. 0) then + if ( ierr /= 0 ) then + print *, ' problem with second sendrecv in exch, ierr = ',ierr + stop + endif + if(iright .ge. 0) then do j=jsta,jend a(iend+1,j)=colr(j) -!GWV ibcoords(iend+1,j)=icolr(j) !GWV TMP ibcoords(iend+1,j)=icolr(j) !GWV TMP -! write(0,*) ' GWVX IBCOLL SETT2 ',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 ) & - write(0,921) j,iend+1,ii,jj,ibcoords(iend+1,j),' GWVX EXCH COORD FAIL j,iend+1,ii,jj,ibcoord ' +! if(iend+1 .eq. 3073) write(0,*) ' GWVX IBCOLL SETT2 ',iend+1,j,icolr(j),ii,jj !GWVX TMP +! if(iend+1 .eq. 3073 .and. ii .ne. 1) write(0,*) ' GWVX IBCOLL FAILED SETT2 ',iend+1,j,icolr(j),ii,jj !GWVX TMP + 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),' GWVX IEXCH COORD FAIL j,iend+1,ii,jj,ibcoord ' 921 format(5i10,a50) ! @@ -136,28 +166,52 @@ SUBROUTINE EXCH(A) call mpi_sendrecv(a(ista,jsta),iend-ista+1,MPI_REAL,idn,1, & & a(ista,jendp1),iend-ista+1,MPI_REAL,iup,1, & & MPI_COMM_COMP,status,ierr) + if ( ierr /= 0 ) then + print *, ' problem with second sendrecv in exch, ierr = ',ierr + stop + endif 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 second sendrecv in exch, ierr = ',ierr + stop + endif ! 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 second sendrecv in exch, ierr = ',ierr + stop + endif 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 second sendrecv in exch, ierr = ',ierr + stop + endif if(ileft .ge. 0) then do j=jsta,jend a(ista-1,j)=coll(j) -!GWV ibcoords(ista-1,j)=icoll(j) !GWV TMP - ibcoords(ista-1,j)=icoll(j) !GWV TMP + ibcoords(ista-1,j)=icoll(j) !GWV TMP ! write(0,*) ' GWVX IBCOLL SETT ',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) & + 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),' GWVX EXCH COORD FAIL j,ista-1,ii,jj,ibcoord ' end do 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 INFAILED IJ ',i,j,ibcoords(i,j),ibl,jbl,ibu,jbu + end do + end do + !! 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 @@ -165,27 +219,45 @@ SUBROUTINE EXCH(A) ! 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 - ibl=max(ista-1,1) - ibu=min(im,iend+1) +!GWVx ibl=max(ista-1,1) +!GWVx ibu=min(im,iend+1) + + ibl=max(ista-1,0) + ibu=min(im+1,iend+1) 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 second sendrecv in exch, ierr = ',ierr + stop + 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 second sendrecv in exch, ierr = ',ierr + stop + 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 second sendrecv in exch, ierr = ',ierr + stop + 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 second sendrecv in exch, ierr = ',ierr + stop + endif !GWV TEST -! write(0,139)' GWVX PRE CORNER ' ,ibcoords(iend,jsta-1),iend,jsta-1,ibcoords(iend,jsta+1),iend,jsta+1,& -! ibcoords(ista,jend+1),ista,jend+1,ibcoords(ista,jend-1),ista,jend-1,me,ileft,iright 139 format(a20,5(i10,i6,i6,'<>')) call mpi_sendrecv(ibcoords(iend,jbl ),1 ,MPI_INTEGER,iright,1 , & @@ -206,74 +278,82 @@ SUBROUTINE EXCH(A) jcc=jbl ii=ibcoords(icc,jcc)/10000 jj=ibcoords(icc,jcc)-(ii*10000) - if(ii .ne. icc .or. jj .ne. jcc) write(0,151) ' CORNER FAIL ilb ll ',icc,jcc,ibcoords(icc,jcc),ii,jj +! if(ii .ne. icc .or. jj .ne. jcc .and. icc .ne. 0 ) write(0,151) ' CORNER FAIL ilb ll ',icc,jcc,ibcoords(icc,jcc),ii,jj + 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 .or. jj .ne. jcc) write(0,151) ' CORNER FAIL ilb ul ',icc,jcc,ibcoords(icc,jcc),ii,jj +! if(ii .ne. icc .or. jj .ne. jcc .and. icc .ne. im+1 ) write(0,151) ' CORNER FAIL ilb ul ',icc,jcc,ibcoords(icc,jcc),ii,jj + 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 .or. jj .ne. jcc) write(0,151) ' CORNER FAIL ilb uu ',icc,jcc,ibcoords(icc,jcc),ii,jj + 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 .or. jj .ne. jcc) write(0,151) ' CORNER FAIL ilb lu ',icc,jcc,ibcoords(icc,jcc),ii,jj + 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 -! print *,'mype=',me,'in EXCH, after second mpi_sendrecv' if(ileft .ge. 0) then -! write(0,119) ileft,me,ibcoords(ista-1,jend+1),ibcoords(ista-1,jend-1),ista-1,jend-1,jend+1 +! write(0,119) ileft,me,ibcoords(ista-1,jend+1),ibcoords(ista-1,jend-1),ista-1,jend-1,jend+1 !GWVX 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 + ! 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 - do j=jbl,jbu - do i=ibl,ibu ! interior check -! do j=jsta,jend -! do i=ista,iend + 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 - 151 format(a20,10i10) + 151 format(a70,10i10) end do end do - +!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 FAILED JBU IJ ',i,j,ibcoords(i,j),ibl,jbl,ibu,jbu + 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 FAILED JBL IJ ',i,j,ibcoords(i,j),ibl,jbl,ibu,jbu + 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 .or. jj .ne. j) write(0,151) 'GWVX FAILED IBL IJ ',i,j,ibcoords(i,j),ibl,jbl,ibu,jbu + 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 .or. jj .ne. j) write(0,151) 'GWVX FAILED IBU IJ ',i,j,ibcoords(i,j),ibl,jbl,ibu,jbu + 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 +! end halo checks if ( ierr /= 0 ) then print *, ' problem with second sendrecv in exch, ierr = ',ierr stop diff --git a/sorc/ncep_post.fd/MDL2THANDPV.f b/sorc/ncep_post.fd/MDL2THANDPV.f index 001cb40e4..65ff039b2 100644 --- a/sorc/ncep_post.fd/MDL2THANDPV.f +++ b/sorc/ncep_post.fd/MDL2THANDPV.f @@ -186,8 +186,8 @@ 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 diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 14e08987e..a49c9bd19 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -95,7 +95,7 @@ SUBROUTINE MPI_FIRST() icoords,ibcoords,bufs,ibufs, & ! GWV TMP rbufs , & ! GWV TMP rcoords,rbcoords, & ! GWV TMP - ISTA_2L, IEND_2U,IVEND_2U ,numx + ISTA_2L, IEND_2U,IVEND_2U ,numx,MODELNAME ! ! use params_mod @@ -285,12 +285,16 @@ SUBROUTINE MPI_FIRST() ! 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 - ista_2l=max(ista-2,1) - iend_2u=min(iend+2,im) - ivend_2u = min(iend + 2, im+1 ) ! print *, ' me, jvend_2u = ',me,jvend_2u ! ! NEW neighbors @@ -413,6 +417,8 @@ 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,& @@ -444,8 +450,9 @@ subroutine fullpole(a,rpoles) end do - call mpi_allgatherv(rpole(ista),icnt2(me),MPI_REAL ,rpoles,icnt2,idsp2,MPI_REAL ,MPI_COMM_WORLD, ierr ) - ! call mpi_gatherv(rpole(ista),icnt2(me),MPI_REAL ,rpoles,icnt2,idsp2,MPI_REAL ,0,MPI_COMM_WORLD, ierr ) + call mpi_allgatherv(rpole(ista),icnt2(me),MPI_REAL,rpoles,icnt2,idsp2,MPI_REAL ,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) print *,' GWVX GATHERED POLES ', ierr ! call mpi_bcast(rpoles,im*2,MPI_REAL,0,MPI_COMM_WORLD, ierr ) ! if(me .eq. 0) print *,' JESSE BCAST POLES ', ierr diff --git a/sorc/ncep_post.fd/UPP_PHYSICS.f b/sorc/ncep_post.fd/UPP_PHYSICS.f index e43c2980c..1f20a1135 100644 --- a/sorc/ncep_post.fd/UPP_PHYSICS.f +++ b/sorc/ncep_post.fd/UPP_PHYSICS.f @@ -1910,8 +1910,8 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) ie(i) = i+1 iw(i) = i-1 enddo - iw(1) = im - ie(im) = 1 +! iw(1) = im +! ie(im) = 1 ! if(1>=jsta .and. 1<=jend)then ! if(cos(gdlat(1,1)*dtr) Date: Thu, 16 Dec 2021 16:44:38 +0000 Subject: [PATCH 57/77] 20211216 Jesse Meng minor update UPP_PHYSICS for i=0:im+1 expansion --- sorc/ncep_post.fd/UPP_PHYSICS.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/sorc/ncep_post.fd/UPP_PHYSICS.f b/sorc/ncep_post.fd/UPP_PHYSICS.f index 1f20a1135..d93ff92be 100644 --- a/sorc/ncep_post.fd/UPP_PHYSICS.f +++ b/sorc/ncep_post.fd/UPP_PHYSICS.f @@ -2647,8 +2647,8 @@ SUBROUTINE CALGRADPS(PS,PSX,PSY) 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) From b7d5d8734ba2ecda5117d7f63eec05b47a5b76f0 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Tue, 4 Jan 2022 21:02:16 +0000 Subject: [PATCH 58/77] 20220104 Jesse Meng add George's minor fix in EXHC.f --- sorc/ncep_post.fd/EXCH.f | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/sorc/ncep_post.fd/EXCH.f b/sorc/ncep_post.fd/EXCH.f index 8dd78522b..d5245f77b 100644 --- a/sorc/ncep_post.fd/EXCH.f +++ b/sorc/ncep_post.fd/EXCH.f @@ -222,8 +222,15 @@ SUBROUTINE EXCH(A) !GWVx ibl=max(ista-1,1) !GWVx ibu=min(im,iend+1) - ibl=max(ista-1,0) - ibu=min(im+1,iend+1) +!GWVXE ibl=max(ista-1,0) +!GWVXE ibu=min(im+1,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) From 5376c98e7d4136f2ce74f9430c24e409309e25ce Mon Sep 17 00:00:00 2001 From: "Jesse.Meng" Date: Tue, 18 Jan 2022 21:19:22 +0000 Subject: [PATCH 59/77] 20220118 Jesse Meng commit George's cleaned up code. --- sorc/ncep_post.fd/EXCH.f | 92 ++++++++++++++++++++--------------- sorc/ncep_post.fd/MPI_FIRST.f | 12 +++-- 2 files changed, 61 insertions(+), 43 deletions(-) diff --git a/sorc/ncep_post.fd/EXCH.f b/sorc/ncep_post.fd/EXCH.f index d5245f77b..d9843b912 100644 --- a/sorc/ncep_post.fd/EXCH.f +++ b/sorc/ncep_post.fd/EXCH.f @@ -49,21 +49,18 @@ SUBROUTINE EXCH(A) real,intent(inout) :: a ( ista_2l:iend_2u,jsta_2l:jend_2u ) real, allocatable :: coll(:), colr(:) integer, allocatable :: icoll(:), icolr(:) - real, allocatable :: rpole(:),rpoles(:,:) - - integer status(MPI_STATUS_SIZE) integer ierr, jstam1, jendp1,j integer size,ubound,lbound integer msglenl, msglenr integer i,ii,jj, ibl,ibu,jbl,jbu,icc,jcc !GWV integer iwest,ieast + integer ifirst + data ifirst/0/ allocate(coll(jm)) allocate(colr(jm)) allocate(icolr(jm)) !GWV allocate(icoll(jm)) !GWV - allocate(rpole(ista:iend)) !GWV - allocate(rpoles(im,2)) !GWV ibl=max(ista-1,1) ibu=min(im,iend+1) jbu=min(jm,jend+1) @@ -78,7 +75,7 @@ SUBROUTINE EXCH(A) ! for global model apply cyclic boundary condition IF(MODELNAME == 'GFS') then - print *,' GWVX CYCLIC BC APPLIED' + 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) !GWVB @@ -91,31 +88,32 @@ SUBROUTINE EXCH(A) & a(ista,jstam1),iend-ista+1,MPI_REAL,idn,1, & & MPI_COMM_COMP,status,ierr) if ( ierr /= 0 ) then - print *, ' problem with second sendrecv in exch, ierr = ',ierr - stop + print *, ' problem with first sendrecv in exch, ierr = ',ierr + stop 6661 endif + 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 + 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 ! build the I columns to send and receive 902 format(' GWVX EXCH BOUNDS ',18i8) msglenl=jend-jsta+1 msglenr=jend-jsta+1 if(iright .lt. 0) msglenr=1 if(ileft .lt. 0) msglenl=1 -!gwv write(0,902),lbound(a),ubound(a),lbound(coll),ubound(coll),ista,jsta,jend,jend-jsta+1,msglenl,msglenr do j=jsta,jend coll(j)=a(ista,j) - icoll(j)=icoords(ista,j) !GWV TMP + if(ifirst .le. 0) icoll(j)=icoords(ista,j) !GWV TMP end do call mpi_barrier(mpi_comm_comp,ierr) @@ -124,19 +122,25 @@ SUBROUTINE EXCH(A) & colr(jsta),msglenr ,MPI_REAL,iright,1, & & MPI_COMM_COMP,status,ierr) if ( ierr /= 0 ) then - print *, ' problem with second sendrecv in exch, ierr = ',ierr - stop + 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, & !GWV TMP & icolr(jsta),msglenr ,MPI_INTEGER,iright,1, & !GWV TMP & MPI_COMM_COMP,status,ierr) if ( ierr /= 0 ) then - print *, ' problem with second sendrecv in exch, ierr = ',ierr - stop + 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(ifirst .le. 0) then !IFIRST ONLY ibcoords(iend+1,j)=icolr(j) !GWV TMP ii=ibcoords(iend+1,j)/10000 jj=ibcoords( iend+1,j)-(ii*10000) @@ -145,6 +149,7 @@ SUBROUTINE EXCH(A) 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),' GWVX IEXCH COORD FAIL j,iend+1,ii,jj,ibcoord ' 921 format(5i10,a50) + endif !IFIRST ! end do @@ -152,58 +157,68 @@ SUBROUTINE EXCH(A) ! print *,'mype=',me,'in EXCH, after first mpi_sendrecv' if ( ierr /= 0 ) then - print *, ' problem with first sendrecv in exch, ierr = ',ierr - stop 6667 + print *, ' problem with fifth sendrecv in exch, ierr = ',ierr + stop 6663 end if jendp1 = min(jend+1,jend_2u) ! Moorthi !GWV. change from full im row exchange to iend-ista+1 subrow exchange, !GWVt of 2D decomp do j=jsta,jend colr(j)=a(iend,j) - icolr(j)=icoords(iend,j) !GWV TMP + if(ifirst .le. 0) icolr(j)=icoords(iend,j) !GWV TMP end do ! send first row to idown's last row+ and receive last row+ from iup's first row call mpi_sendrecv(a(ista,jsta),iend-ista+1,MPI_REAL,idn,1, & & a(ista,jendp1),iend-ista+1,MPI_REAL,iup,1, & & MPI_COMM_COMP,status,ierr) if ( ierr /= 0 ) then - print *, ' problem with second sendrecv in exch, ierr = ',ierr - stop + print *, ' problem with sixth sendrecv in exch, ierr = ',ierr + stop 6664 endif + 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 second sendrecv in exch, ierr = ',ierr - stop + print *, ' problem with seventh sendrecv in exch, ierr = ',ierr + stop 7664 endif + endif ! IFIRST ! 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 second sendrecv in exch, ierr = ',ierr - stop + 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 second sendrecv in exch, ierr = ',ierr - stop + 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(ifirst .le. 0) then + ibcoords(ista-1,j)=icoll(j) !GWV TMP ! write(0,*) ' GWVX IBCOLL SETT ',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),' GWVX EXCH COORD FAIL j,ista-1,ii,jj,ibcoord ' + endif !IFIRST end do + endif ! interior check + + if(ifirst .le. 0) then do j=jsta,jend do i=ista,iend ii=ibcoords(i,j)/10000 @@ -211,6 +226,7 @@ SUBROUTINE EXCH(A) if(ii .ne. i .or. jj .ne. j) write(0,151) 'GWVX INFAILED IJ ',i,j,ibcoords(i,j),ibl,jbl,ibu,jbu end do end do + endif !IFIRST !! corner points. After the exchanges above, corner points are replicated in ! neighbour halos so we can get them from the neighbors rather than @@ -222,8 +238,6 @@ SUBROUTINE EXCH(A) !GWVx ibl=max(ista-1,1) !GWVx ibu=min(im,iend+1) -!GWVXE ibl=max(ista-1,0) -!GWVXE ibu=min(im+1,iend+1) ibl=max(ista-1,1) ibu=min(im,iend+1) if(modelname == 'GFS') then @@ -238,35 +252,36 @@ SUBROUTINE EXCH(A) & a(ibl ,jbl ),1, MPI_REAL,ileft ,1, & & MPI_COMM_COMP,status,ierr) if ( ierr /= 0 ) then - print *, ' problem with second sendrecv in exch, ierr = ',ierr - stop + 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 second sendrecv in exch, ierr = ',ierr - stop + 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 second sendrecv in exch, ierr = ',ierr - stop + 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 second sendrecv in exch, ierr = ',ierr - stop + print *, ' problem with thirteenth sendrecv in exch, ierr = ',ierr + stop 6774 endif !GWV TEST 139 format(a20,5(i10,i6,i6,'<>')) + 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) @@ -360,14 +375,15 @@ SUBROUTINE EXCH(A) 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 ! 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) -! write(0,*) ' GWVX END EXCHHH ' -! + ifirst=ifirst+1 end !!@PROCESS NOCHECK diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index a49c9bd19..19ca9b019 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -261,8 +261,9 @@ SUBROUTINE MPI_FIRST() idsp2(i)=isumm2 if(jsx .eq. 1 .or. jex .eq. jm) isumm2=isumm2+(iex-isx+1) if ( me == 0 ) then - print 196, ' GWVXX i, icnt(i),idsp(i) = ',i,icnt(i), & - idsp(i),icnt2(i),idsp2(i) +!GWVXE print 196, ' GWVXX i, icnt(i),idsp(i) = ',i,icnt(i), & +!GWVXE idsp(i),icnt2(i),idsp2(i) + continue end if 196 format(a36,15i10) !GWV Create send buffer for scatter. This is now needed because we are no @@ -350,7 +351,7 @@ SUBROUTINE MPI_FIRST() end do allocate(ipoles(im,2),ipole(ista:iend)) allocate(rpoles(im,2),rpole(ista:iend)) - write (0,196) ' GWVX ISX IEX bounds',ista,iend,me,lbound(ipole),ubound(ipole) +!GWVXE write (0,196) ' GWVX ISX IEX bounds',ista,iend,me,lbound(ipole),ubound(ipole) ipole=9900000 ipoles=-999999999 @@ -390,11 +391,12 @@ SUBROUTINE MPI_FIRST() do i=1,im ii=rpoles(i,j)/4000 jj=rpoles(i,j) -ii*4000 - if(me .eq. 0) print 107,' GWVX IPOLES,i,j,ii,jj',i,j,ii,jj,ifix(rpoles(i,j)) +!GWVXE if(me .eq. 0) print 107,' GWVX IPOLES,i,j,ii,jj',i,j,ii,jj,ifix(rpoles(i,j)) if(ii .ne. i .or. jj .ne. 1 .and. jj .ne. jm ) then write(0,169)' GWVX IPOLES BAD POINT',rpoles(i,j),ii,i,jj,' jm= ',jm else - write(0,169)' GWVX IPOLES GOOD POINT',rpoles(i,j),ii,i,jj,' jm= ',jm + continue +! write(0,169)' GWVX IPOLES GOOD POINT',rpoles(i,j),ii,i,jj,' jm= ',jm endif 107 format(a20,10i10) 169 format(a25,f20.1,3i10,a10,4i10) From 5aab68f58b430f0dfc5b2e8521acddffcf7eb39b Mon Sep 17 00:00:00 2001 From: "Jesse.Meng" Date: Thu, 3 Feb 2022 14:50:23 +0000 Subject: [PATCH 60/77] 20220203 Jesse Meng - update MAPSSLP.f to be consistent with develop branch. --- sorc/ncep_post.fd/MAPSSLP.f | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/sorc/ncep_post.fd/MAPSSLP.f b/sorc/ncep_post.fd/MAPSSLP.f index 4ef1d8a44..5d1ca0125 100644 --- a/sorc/ncep_post.fd/MAPSSLP.f +++ b/sorc/ncep_post.fd/MAPSSLP.f @@ -44,12 +44,14 @@ SUBROUTINE MAPSSLP(TPRES) !$omp parallel do private(i,j) DO J=JSTA,JEND DO I=ISTA,IEND - if(SPL(L) == 70000. .and. TPRES(I,J,L) Date: Tue, 22 Feb 2022 15:13:37 +0000 Subject: [PATCH 61/77] 20220222 Jesse Meng add checkcoords flag in EXCH.f to move around George's debug code. --- sorc/ncep_post.fd/EXCH.f | 28 ++++++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/sorc/ncep_post.fd/EXCH.f b/sorc/ncep_post.fd/EXCH.f index d9843b912..ebe88e561 100644 --- a/sorc/ncep_post.fd/EXCH.f +++ b/sorc/ncep_post.fd/EXCH.f @@ -56,6 +56,9 @@ SUBROUTINE EXCH(A) integer i,ii,jj, ibl,ibu,jbl,jbu,icc,jcc !GWV integer iwest,ieast integer ifirst + + logical, parameter :: checkcoords = .false. + data ifirst/0/ allocate(coll(jm)) allocate(colr(jm)) @@ -91,6 +94,8 @@ SUBROUTINE EXCH(A) 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, & @@ -105,6 +110,8 @@ SUBROUTINE EXCH(A) 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 902 format(' GWVX EXCH BOUNDS ',18i8) msglenl=jend-jsta+1 @@ -113,7 +120,7 @@ SUBROUTINE EXCH(A) if(ileft .lt. 0) msglenl=1 do j=jsta,jend coll(j)=a(ista,j) - if(ifirst .le. 0) icoll(j)=icoords(ista,j) !GWV TMP +! if(ifirst .le. 0) icoll(j)=icoords(ista,j) !GWV TMP end do call mpi_barrier(mpi_comm_comp,ierr) @@ -140,7 +147,8 @@ SUBROUTINE EXCH(A) do j=jsta,jend a(iend+1,j)=colr(j) - if(ifirst .le. 0) then !IFIRST ONLY + if(checkcoords) then + if(ifirst .le. 0) then !IFIRST ONLY ibcoords(iend+1,j)=icolr(j) !GWV TMP ii=ibcoords(iend+1,j)/10000 jj=ibcoords( iend+1,j)-(ii*10000) @@ -150,6 +158,7 @@ SUBROUTINE EXCH(A) write(0,921) j,iend+1,ii,jj,ibcoords(iend+1,j),' GWVX IEXCH COORD FAIL j,iend+1,ii,jj,ibcoord ' 921 format(5i10,a50) endif !IFIRST + endif !checkcoords ! end do @@ -165,7 +174,7 @@ SUBROUTINE EXCH(A) !GWVt of 2D decomp do j=jsta,jend colr(j)=a(iend,j) - if(ifirst .le. 0) icolr(j)=icoords(iend,j) !GWV TMP +! if(ifirst .le. 0) icolr(j)=icoords(iend,j) !GWV TMP 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, & @@ -175,7 +184,9 @@ SUBROUTINE EXCH(A) print *, ' problem with sixth sendrecv in exch, ierr = ',ierr stop 6664 endif - if (ifirst .le. 0) then + + 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) @@ -184,6 +195,7 @@ SUBROUTINE EXCH(A) 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, & @@ -204,6 +216,7 @@ SUBROUTINE EXCH(A) 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) !GWV TMP @@ -213,11 +226,13 @@ SUBROUTINE EXCH(A) 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),' GWVX 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 @@ -227,6 +242,8 @@ SUBROUTINE EXCH(A) 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 @@ -281,6 +298,7 @@ SUBROUTINE EXCH(A) !GWV TEST 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, & @@ -377,6 +395,8 @@ SUBROUTINE EXCH(A) 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 From a4bd92da3dedc2b2192bbf1948109c68deb63bb9 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Wed, 2 Mar 2022 19:14:51 +0000 Subject: [PATCH 62/77] 20220302 Jesse Meng Restrict computation from undefined grids --- sorc/ncep_post.fd/SLP_new.f | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/sorc/ncep_post.fd/SLP_new.f b/sorc/ncep_post.fd/SLP_new.f index 58789094b..ef7a31d75 100644 --- a/sorc/ncep_post.fd/SLP_new.f +++ b/sorc/ncep_post.fd/SLP_new.f @@ -451,6 +451,7 @@ SUBROUTINE MEMSLP(TPRES,QPRES,FIPRES) ! LMAP1 = LMHIJ+1 DO L=LMAP1,LSM + IF(GZ1 SPL(LP))THEN LLMH = NINT(LMH(I,J)) + IF(T(I,J,LLMH) Date: Fri, 4 Mar 2022 09:20:16 -0500 Subject: [PATCH 63/77] 20220304 Bo Cui Add a reset of numx=1 if remainder of num_procs/numx is not 0 --- sorc/ncep_post.fd/WRFPOST.f | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/sorc/ncep_post.fd/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f index cfbbd5925..8f2c6cbe7 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -234,6 +234,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 @@ -306,6 +307,19 @@ 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, nunmx=',numx + endif if(me == 0) then print*,'komax,iret for nampgb= ',komax,iret print*,'komax,kpo,kth,th,kpv,pv,fileNameAER,popascal= ',komax,kpo & From 97c02a52abc113e5ef787997a2c9693c3410d874 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Fri, 11 Mar 2022 01:54:26 +0000 Subject: [PATCH 64/77] 20220310 Jesse Meng Add a reset of numx=1 if(numx>num_procs/2) --- sorc/ncep_post.fd/MPI_FIRST.f | 5 ++--- sorc/ncep_post.fd/WRFPOST.f | 12 +++++++++++- ush/gfs_nceppost.sh | 2 +- 3 files changed, 14 insertions(+), 5 deletions(-) diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 19ca9b019..5bcbb8688 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -447,9 +447,8 @@ subroutine fullpole(a,rpoles) data iwest,ieast/0,0/ allocate(rpole(ista:iend)) !GWV 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 .gt. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt.0) rpole(i)=a(i,jm) - + 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_WORLD, ierr ) diff --git a/sorc/ncep_post.fd/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f index 8f2c6cbe7..bcce7e8f1 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -318,8 +318,18 @@ PROGRAM WRFPOST endif ! stop 9999 numx=1 - if(me == 0) print*,'Warning!!! Reset numx as 1, nunmx=',numx + 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 & diff --git a/ush/gfs_nceppost.sh b/ush/gfs_nceppost.sh index e97dc9935..2ee5afcde 100755 --- a/ush/gfs_nceppost.sh +++ b/ush/gfs_nceppost.sh @@ -294,7 +294,7 @@ export pgm=$PGM $LOGSCRIPT cat <postgp.inp.nml$$ &NAMPGB - $POSTGPVARS numx=1 + $POSTGPVARS numx=2 EOF cat <>postgp.inp.nml$$ From 839941627b4c6b39a2ab9b519b6ef0b46270117e Mon Sep 17 00:00:00 2001 From: wx22mj Date: Tue, 22 Mar 2022 21:30:28 +0000 Subject: [PATCH 65/77] 20220322 Jesse Meng mpi_allgatherv change communicator to MPI_COMM_COMP --- sorc/ncep_post.fd/MPI_FIRST.f | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 5bcbb8688..692750172 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -451,11 +451,11 @@ subroutine fullpole(a,rpoles) 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_WORLD, ierr ) - ! call mpi_gatherv(rpole(ista),icnt2(me),MPI_REAL - ! ,rpoles,icnt2,idsp2,MPI_REAL ,0,MPI_COMM_WORLD, ierr ) + call mpi_allgatherv(rpole(ista),icnt2(me),MPI_REAL,rpoles,icnt2,idsp2,MPI_REAL, MPI_COMM_COMP, ierr ) + !call mpi_allgatherv(rpole(ista),icnt2(me),MPI_REAL,rpoles,icnt2,idsp2,MPI_REAL ,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) print *,' GWVX GATHERED POLES ', ierr - ! call mpi_bcast(rpoles,im*2,MPI_REAL,0,MPI_COMM_WORLD, ierr ) + ! call mpi_bcast(rpoles,im*2,MPI_REAL,0,MPI_COMM_WORLD, ierr ) ! if(me .eq. 0) print *,' JESSE BCAST POLES ', ierr call mpi_barrier(mpi_comm_comp,ierr) From 36bd6757dfe55d4a99d882d34421bf7ca82bb4fa Mon Sep 17 00:00:00 2001 From: wx22mj Date: Mon, 28 Mar 2022 20:13:41 +0000 Subject: [PATCH 66/77] 20220328 Jesse Meng bug fix for passing 2d subarrays between subroutines --- sorc/ncep_post.fd/MDL2P.f | 8 +++++--- sorc/ncep_post.fd/MDLFLD.f | 8 ++++---- sorc/ncep_post.fd/MISCLN.f | 4 ++-- sorc/ncep_post.fd/SURFCE.f | 2 +- 4 files changed, 12 insertions(+), 10 deletions(-) diff --git a/sorc/ncep_post.fd/MDL2P.f b/sorc/ncep_post.fd/MDL2P.f index 0a5b396e2..e85cc5cb7 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -147,6 +147,8 @@ SUBROUTINE MDL2P(iostatusD3D) ! ! START MDL2P. ! + if(me==0) print*, 'MDL2P SMFLAG=',SMFLAG + if (modelname == 'GFS') then zero = 0.0 else @@ -1374,7 +1376,7 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO ENDDO ! - CALL CALDWP(EGRID2(ista,jsta),QSL(ista,jsta),EGRID1(ista,jsta),TSL(ista,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=ISTA,IEND @@ -1649,7 +1651,7 @@ SUBROUTINE MDL2P(iostatusD3D) ENDIF ENDDO ENDDO - CALL CALSTRM(EGRID2(ista,jsta),EGRID1(ista,jsta)) + CALL CALSTRM(EGRID2(ista:iend,jsta:jend),EGRID1(ista:iend,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND DO I=ISTA,IEND @@ -1948,7 +1950,7 @@ 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(ista,jsta), SAVRH, OSL(ista,jsta), EGRID1(ista,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 diff --git a/sorc/ncep_post.fd/MDLFLD.f b/sorc/ncep_post.fd/MDLFLD.f index f1291ab4b..b3dbe03f3 100644 --- a/sorc/ncep_post.fd/MDLFLD.f +++ b/sorc/ncep_post.fd/MDLFLD.f @@ -1514,7 +1514,7 @@ SUBROUTINE MDLFLD T1D(I,J) = T(I,J,LL) ENDDO ENDDO - CALL CALPOT(P1D(1,jsta),T1D(1,jsta),EGRID3(1,jsta)) + CALL CALPOT(P1D(ista:iend,jsta:jend),T1D(ista:iend,jsta:jend),EGRID3(ista:iend,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND @@ -1550,7 +1550,7 @@ SUBROUTINE MDLFLD T1D(I,J) = T(I,J,LL) ENDDO ENDDO - CALL CALPOT(P1D(1,jsta),T1D(1,jsta),EGRID3(1,jsta)) + CALL CALPOT(P1D(ista:iend,jsta:jend),T1D(ista:iend,jsta:jend),EGRID3(ista:iend,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND @@ -1639,7 +1639,7 @@ SUBROUTINE MDLFLD Q1D(I,J) = Q(I,J,LL) ENDDO ENDDO - CALL CALDWP(P1D(1,jsta),Q1D(1,jsta),EGRID3(1,jsta),T1D(1,jsta)) + CALL CALDWP(P1D(ista:iend,jsta:jend),Q1D(ista:iend,jsta:jend),EGRID3(ista:iend,jsta:jend),T1D(ista:iend,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND DO I=ista,iend @@ -1909,7 +1909,7 @@ SUBROUTINE MDLFLD EGRID1(I,J) = ZMID(I,J,LL) ENDDO ENDDO - CALL CALSTRM(EGRID1(1,jsta),EGRID2(1,jsta)) + CALL CALSTRM(EGRID1(ista:iend,jsta:jend),EGRID2(ista:iend,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND DO I=ista,iend diff --git a/sorc/ncep_post.fd/MISCLN.f b/sorc/ncep_post.fd/MISCLN.f index ec083dffa..84417aaf2 100644 --- a/sorc/ncep_post.fd/MISCLN.f +++ b/sorc/ncep_post.fd/MISCLN.f @@ -1909,8 +1909,8 @@ SUBROUTINE MISCLN ! BOUNDARY LAYER DEWPOINT TEMPERATURE. IF (IGET(070)>0) THEN IF (LVLS(LBND,IGET(070))>0) THEN - CALL CALDWP(PBND(ista,jsta,LBND), QBND(ista,jsta,LBND), & - GRID1(ista:iend,jsta:jend), TBND(ista,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)) diff --git a/sorc/ncep_post.fd/SURFCE.f b/sorc/ncep_post.fd/SURFCE.f index d17ec2224..ad294ffcb 100644 --- a/sorc/ncep_post.fd/SURFCE.f +++ b/sorc/ncep_post.fd/SURFCE.f @@ -5602,7 +5602,7 @@ 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=ISTA,IEND IF(USTAR(I,J) < spval) GRID1(I,J)=EGRID1(I,J) From 8522567a6f41e577aa971197f05655911753571b Mon Sep 17 00:00:00 2001 From: wx22mj Date: Tue, 29 Mar 2022 02:06:42 +0000 Subject: [PATCH 67/77] 20220328 Jesse Meng minor fix for CLDRAD call BOUND variable array size --- sorc/ncep_post.fd/CLDRAD.f | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index 5f09a353a..da852b6c0 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -427,7 +427,7 @@ SUBROUTINE CLDRAD IF(FIS(I,J) >= SPVAL) GRID1(I,J)=spval END DO END DO - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(080)) @@ -447,7 +447,7 @@ SUBROUTINE CLDRAD ! IF (IGET(735) > 0) THEN CALL CALPW(GRID1(ista:iend,jsta:jend),19) - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(735)) @@ -467,7 +467,7 @@ SUBROUTINE CLDRAD ! IF (IGET(736) > 0) THEN CALL CALPW(GRID1(ista:iend,jsta:iend),18) - CALL BOUND(GRID1(ista:iend,jsta:iend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(736)) @@ -510,7 +510,7 @@ SUBROUTINE CLDRAD END IF ! GFS END IF ! RAPR - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(IGET(200) > 0) then if(grib == "grib2" )then cfld = cfld + 1 @@ -554,7 +554,7 @@ SUBROUTINE CLDRAD ELSE CALL CALPW(GRID1(ista:iend,jsta:jend),3) END IF - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(201)) @@ -572,7 +572,7 @@ SUBROUTINE CLDRAD ! TOTAL COLUMN RAIN IF (IGET(202) > 0) THEN CALL CALPW(GRID1(ista:iend,jsta:jend),4) - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(202)) @@ -590,7 +590,7 @@ SUBROUTINE CLDRAD ! TOTAL COLUMN SNOW IF (IGET(203) > 0) THEN CALL CALPW(GRID1(ista:iend,jsta:jend),5) - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(203)) @@ -609,7 +609,7 @@ SUBROUTINE CLDRAD ! TOTAL COLUMN GRAUPEL IF (IGET(428) > 0) THEN CALL CALPW(GRID1(ista:iend,jsta:jend),16) - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(428)) @@ -628,7 +628,7 @@ SUBROUTINE CLDRAD ! TOTAL COLUMN CONDENSATE IF (IGET(204) > 0) THEN CALL CALPW(GRID1(ista:iend,jsta:jend),6) - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(204)) @@ -646,7 +646,7 @@ SUBROUTINE CLDRAD ! TOTAL COLUMN SUPERCOOLED (<0C) LIQUID WATER IF (IGET(285) > 0) THEN CALL CALPW(GRID1(ista:iend,jsta:jend),7) - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(285)) @@ -664,7 +664,7 @@ SUBROUTINE CLDRAD ! TOTAL COLUMN MELTING (>0C) ICE IF (IGET(286) > 0) THEN CALL CALPW(GRID1(ista:iend,jsta:jend),8) - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(286)) @@ -955,7 +955,7 @@ 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=ISTA,IEND @@ -5025,7 +5025,7 @@ SUBROUTINE CLDRAD GRID1(i,j) = AOD(i,j) enddo enddo - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(INDX)) @@ -5052,7 +5052,7 @@ SUBROUTINE CLDRAD ENDIF ENDDO ENDDO - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(649)) @@ -5076,7 +5076,7 @@ SUBROUTINE CLDRAD ENDIF ENDDO ENDDO - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(648)) @@ -5100,7 +5100,7 @@ SUBROUTINE CLDRAD GRID1(I,J)=SCA2D(I,J) ENDDO ENDDO - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(650)) @@ -5123,7 +5123,7 @@ SUBROUTINE CLDRAD IF ( II == 5 ) GRID1(I,J) = AOD_BC(I,J) ENDDO ENDDO - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(JJ)) @@ -5144,7 +5144,7 @@ SUBROUTINE CLDRAD IF ( II == 5 ) GRID1(I,J) = SCA_BC(I,J) ENDDO ENDDO - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(JJ)) @@ -5175,7 +5175,7 @@ SUBROUTINE CLDRAD ENDDO if(debugprint)print *,'output angstrom exp,angst=',maxval(angst(ista:iend,jsta:jend)), & minval(angst(ista:iend,jsta:jend)) - CALL BOUND(GRID1(ista:iend,jsta:jend),D00,H99999) + CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(656)) From b78a3a3cb7790b2bd787f976a798d4916f01ec97 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Wed, 30 Mar 2022 13:42:47 +0000 Subject: [PATCH 68/77] 20220330 Jesse Meng fix cloud cover variabes full field collection in 2d decomp --- sorc/ncep_post.fd/CLDRAD.f | 17 ++++++-- sorc/ncep_post.fd/COLLECT_LOC.f | 70 +++++++++++++++++++++++++++++++++ 2 files changed, 84 insertions(+), 3 deletions(-) diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index da852b6c0..422caf06a 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -177,6 +177,7 @@ SUBROUTINE CLDRAD ! real dummy(ista:iend,jsta:jend) integer idummy(ista:iend,jsta:jend) + real full_dummy(im,jm) ! ! --- Revision added for GOCART --- @@ -966,7 +967,10 @@ SUBROUTINE CLDRAD endif ENDDO ENDDO - CALL AllGETHERV(FULL_CLD) +! CALL AllGETHERV(FULL_CLD) + full_dummy=spval + CALL COLLECT_ALL(FULL_CLD(ISTA:IEND,JSTA:JEND),full_dummy) + FULL_CLD=full_dummy DO J=JSTA,JEND DO I=ISTA,IEND NUMPTS=0 @@ -2216,8 +2220,15 @@ SUBROUTINE CLDRAD 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=ISTA,IEND diff --git a/sorc/ncep_post.fd/COLLECT_LOC.f b/sorc/ncep_post.fd/COLLECT_LOC.f index 652b126de..0d8ce1ff7 100644 --- a/sorc/ncep_post.fd/COLLECT_LOC.f +++ b/sorc/ncep_post.fd/COLLECT_LOC.f @@ -91,3 +91,73 @@ SUBROUTINE COLLECT_LOC ( A, B ) 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_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: a + real, dimension(ista:iend,jsta:jend), intent(in) :: a + real, dimension(im,jm), intent(out) :: b + integer ierr,n + real, allocatable :: rbufs(:) + write(0,*) ' GWVX COLL CALL' + 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)' GWVX 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 + +!UNCOMMENT POST TEST call mpi_gatherv(rbufs,icnt(me),MPI_REAL, +!buff,icnt,idsp,MPI_REAL,0,MPI_COMM_COMP, ierr ) +! call mpi_gatherv(rbufs,icnt(me),MPI_REAL, +! buff,icnt,idsp,MPI_REAL,0,mpi_comm_comp, ierr ) !GWVX COMMENT + call mpi_allgatherv(rbufs,icnt(me),MPI_REAL,buff,icnt,idsp,MPI_REAL, mpi_comm_comp, ierr ) !GWVX COMMENT + call mpi_barrier(mpi_comm_comp,ierr) + +!GWV reshape the gathered array and collect in all procs +! 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)' GWVX BOUNDS FAIL in reshape',isum,ii,jj,im*jm,im,im*jm + 901 format(a30,10i10) + b(ii,jj)=buff(isum) + isum=isum+1 + end do + end do + end do + + +! end if + endif + deallocate(buff) + deallocate(rbufs) + + end + From d3d5954603394653dcac88086f90005bb3fb305e Mon Sep 17 00:00:00 2001 From: wx22mj Date: Fri, 1 Apr 2022 13:57:34 +0000 Subject: [PATCH 69/77] 20220401 Jesse Meng minor fix for CALMCVG.f and update CALUPDHEL.f with develop --- sorc/ncep_post.fd/CALMCVG.f | 8 ++++---- sorc/ncep_post.fd/CALUPDHEL.f | 7 +++++++ 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/sorc/ncep_post.fd/CALMCVG.f b/sorc/ncep_post.fd/CALMCVG.f index b354052d6..d2ec706e3 100644 --- a/sorc/ncep_post.fd/CALMCVG.f +++ b/sorc/ncep_post.fd/CALMCVG.f @@ -81,6 +81,10 @@ 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 @@ -96,10 +100,6 @@ SUBROUTINE CALMCVG(Q1D,U1D,V1D,QCNVG) IF (VWND(I,J) == SPVAL) VWND(I,J) = D00 ENDDO ENDDO - - CALL EXCH(Q1D) - CALL EXCH(VWND) - CALL EXCH(UWND) ! IF(gridtype == 'A')THEN !$omp parallel do private(i,j,qudx,qvdy,r2dx,r2dy) diff --git a/sorc/ncep_post.fd/CALUPDHEL.f b/sorc/ncep_post.fd/CALUPDHEL.f index 65bf0fa50..ff9704506 100644 --- a/sorc/ncep_post.fd/CALUPDHEL.f +++ b/sorc/ncep_post.fd/CALUPDHEL.f @@ -103,6 +103,8 @@ SUBROUTINE CALUPDHEL(UPDHEL) DO J=JSTA_M,JEND_M DO I=ISTA_M,IEND_M + IF (HTSFC(I,J) < spval) THEN + R2DX = 1./(2.*DX(I,J)) R2DY = 1./(2.*DY(I,J)) @@ -135,6 +137,11 @@ SUBROUTINE CALUPDHEL(UPDHEL) ENDIF ENDDO l_loop + + ELSE + UPDHEL(I,J) = spval + ENDIF + ENDDO ENDDO From 5186eb2b0745cf863a82f7de072d85ee9db39d5a Mon Sep 17 00:00:00 2001 From: BoCui-NOAA <53531984+BoCui-NOAA@users.noreply.github.com> Date: Fri, 22 Apr 2022 10:12:53 -0400 Subject: [PATCH 70/77] 20220414 BoCui sync and merge UPP/develop into post_2d_decomp (#7) * Added lambert conformal projection for FV3SAR and handled composite reflectivity correctly (#14) (#2) * exec is selectable for executable directory (#448) * Doxygen for CALGUST (#451) * Doxygen for CALDRG.f * This is part of Issue #392 Fixes the doxygen warnings in CALGUST.f Please review this subroutine. Thank you. * The fix in CALUPDHEL.f (#458) * Modify CALUPDHEL.f for restricting undefined grids in computation. * Update VERSION to 10.0.12. * Bug fix for SLLEVEL bound issue when not RUC LSM (#463) Co-authored-by: Tracy * Doxygen caldrg caldwcp calgust refinement (#464) * Further refinement to the tables and logs. * Further refinement to the tables and logs. (#455) * This is part of Issue #392 (#460) Fixes the doxygen warnings in CALHEL.f CALHEL2.f CALHEL3.f Please review this subroutine. Thank you. * Unify global and regional FV3 read interfaces (#453) * Unify the interfaces for reading FV3 outputs in netcdf. * Remove interface INITPOST_GFS_NETCDF_PARA. * Remove INITPOST_GFS_NETCDF.f. * Remove the capability of serial netcdf reading FV3 outputs. * Correct reading rswinc. * Remove duplication in CLDRAD.f. * Remove duplicated avgalbedo reading * Add changes for reading pwat from model. * Clean up commented out code * Clean up duplicated lines * Add ability to compile script to use non-intel compilers; add Cheyenne modulefiles for gnu and intel (#468) * Add cheyenne modulefile * Intel 19 --> 2021 * Add ability to specify compiler; move all existing modulefiles to ${name}_intel since they are all for intel compilers; add "cheyenne_gnu" modulefile * Revert move of intel modulefiles; now the implicit default for a modulefile is intel, only gnu and other compilers will have the compiler name appended to the modulefile * Allow for lua modulefiles with ".lua" appended * This is part of Issue #392 (#465) Fixes the doxygen warnings in CALLCL.f CALMCVG.f CALMICT.f * This is part of Issue #392 (#466) Fixes the doxygen warnings in CALPBL.f CALPBLREGIME.f CALPOT.f CALPW.f. * Doxygen in CALRAD_WCLOUD_newcrtm.f CALRCH.f CALSTRM.f CALTAU.f CALTHTE.f CALUPDHEL.f. (#467) * This is part of Issue #392. Fixes the doxygen warnings in CALRAD_WCLOUD_newcrtm.f CALRCH.f CALSTRM.f CALTAU.f CALTHTE.f CALUPDHEL.f. * Fixed typo. * Update to PR #458. * Doxygen in CALVOR.f, CALWXT_BOURG.f, CLDRAD.f, COLLECT.f, COLLECT_LOC.f, DEALLOCATE.f, and DEALLOCATE.f (#469) * This is part of Issue #392. Fixes the doxygen warnings in CALVOR.f, CALWXT_BOURG.f, CLDRAD.f, COLLECT.f, COLLECT_LOC.f, DEALLOCATE.f, and DEALLOCATE.f. * Fixed minor bug in CALVOR.f. * Update to PR#453. * More updates. * 20220411 Bo Cui 2D decompositio CALVOR.f and INITPOST_NETCDF.f * 20220411 Bo Cui update doxgen and global and regional FV3 read interface * 20220414 Bo Cui: remove read_netcdf_2d_scatter and read_netcdf_3d_scatter from INITPOST_NETCDF.f * 20220415 Bo Cui delete CALVOR.f, add exch of gdlon in INITPOST_NETCDF.f * 20220421 Bo Cui Doxygen in UPP_PHYSICS.f,add restriction run 2D decomp only for GFS/FV3R in WRFPOST.f Co-authored-by: WenMeng-NOAA <48260754+WenMeng-NOAA@users.noreply.github.com> Co-authored-by: Wen Meng Co-authored-by: Chan-Hoo.Jeon-NOAA <60152248+chan-hoo@users.noreply.github.com> Co-authored-by: kayeekayee Co-authored-by: Tracy Hertneky <39317287+hertneky@users.noreply.github.com> Co-authored-by: Tracy Co-authored-by: Michael Kavulich --- CMakeLists.txt | 6 + README.md | 6 +- VERSION | 2 +- modulefiles/cheyenne | 40 + modulefiles/cheyenne_gnu | 41 + sorc/ncep_post.fd/ALLOCATE_ALL.f | 3 + sorc/ncep_post.fd/CALDRG.f | 21 +- sorc/ncep_post.fd/CALDWP.f | 26 +- sorc/ncep_post.fd/CALGUST.f | 61 +- sorc/ncep_post.fd/CALHEL.f | 117 +- sorc/ncep_post.fd/CALHEL2.f | 124 +- sorc/ncep_post.fd/CALHEL3.f | 123 +- sorc/ncep_post.fd/CALLCL.f | 76 +- sorc/ncep_post.fd/CALMCVG.f | 84 +- sorc/ncep_post.fd/CALMICT.f | 182 +- sorc/ncep_post.fd/CALPBL.f | 45 +- sorc/ncep_post.fd/CALPBLREGIME.f | 70 +- sorc/ncep_post.fd/CALPOT.f | 55 +- sorc/ncep_post.fd/CALPW.f | 97 +- sorc/ncep_post.fd/CALRAD_WCLOUD_newcrtm.f | 46 +- sorc/ncep_post.fd/CALRCH.f | 62 +- sorc/ncep_post.fd/CALSTRM.f | 63 +- sorc/ncep_post.fd/CALTAU.f | 69 +- sorc/ncep_post.fd/CALTHTE.f | 60 +- sorc/ncep_post.fd/CALUPDHEL.f | 50 +- sorc/ncep_post.fd/CALWXT_BOURG.f | 116 +- sorc/ncep_post.fd/CLDRAD.f | 192 +- sorc/ncep_post.fd/CMakeLists.txt | 6 +- sorc/ncep_post.fd/COLLECT.f | 44 +- sorc/ncep_post.fd/COLLECT_LOC.f | 44 +- sorc/ncep_post.fd/DEALLOCATE.f | 44 +- sorc/ncep_post.fd/DEWPOINT.f | 89 +- sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f | 2761 ------------------ sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f | 2691 ----------------- sorc/ncep_post.fd/INITPOST_NETCDF.f | 1682 +++++------ sorc/ncep_post.fd/UPP_PHYSICS.f | 880 +++--- sorc/ncep_post.fd/VRBLS2D_mod.f | 2 +- sorc/ncep_post.fd/WRFPOST.f | 89 +- tests/compile_upp.sh | 28 +- 39 files changed, 2107 insertions(+), 8090 deletions(-) create mode 100644 modulefiles/cheyenne create mode 100644 modulefiles/cheyenne_gnu delete mode 100644 sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f delete mode 100644 sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f diff --git a/CMakeLists.txt b/CMakeLists.txt index 8100dd0d2..ca0255482 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -63,6 +63,12 @@ if(BUILD_POSTEXEC) endif() endif() +### Switch RUNTIME DESTINATION DIR between bin and exec +set(exec_dir bin) +if(EMC_EXEC_DIR) + set(exec_dir exec) +endif() + add_subdirectory(sorc) add_subdirectory(parm) diff --git a/README.md b/README.md index 6f80fd158..4d403a302 100644 --- a/README.md +++ b/README.md @@ -110,9 +110,9 @@ Builds include: ``` mkdir build cd build -cmake .. -DCMAKE_INSTALL_PREFIX=/path/to/install -make -make test +cmake .. -DCMAKE_INSTALL_PREFIX=/path/to/install +(or cmake .. -DCMAKE_INSTALL_PREFIX=/path/to/install -DEMC_EXEC_DIR=ON) +make -j 4 make install ``` diff --git a/VERSION b/VERSION index 89acc9519..59a550906 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -10.0.11 +10.0.12 diff --git a/modulefiles/cheyenne b/modulefiles/cheyenne new file mode 100644 index 000000000..75ae507e5 --- /dev/null +++ b/modulefiles/cheyenne @@ -0,0 +1,40 @@ +#%Module# + +proc ModulesHelp { } { +puts stderr "Loads modules required for building upp" +} +module-whatis "Loads UPP prerequisites on Cheyenne for Intel 2021.2" + +module purge + +module load cmake/3.18.2 +module load ncarenv/1.3 +module load intel/2021.2 +module load mpt/2.22 +module load ncarcompilers/0.5.0 +module unload netcdf + +module use /glade/p/ral/jntp/GMTB/tools/hpc-stack-v1.2.0/modulefiles/stack +module load hpc/1.2.0 +module load hpc-intel/2021.2 +module load hpc-mpt/2.22 + +module load jasper/2.0.25 +module load zlib/1.2.11 +module load png/1.6.35 + +module load hdf5/1.10.6 +module load netcdf/4.7.4 + +module load bacio/2.4.1 +module load crtm/2.3.0 +module load g2/3.4.2 +module load g2tmpl/1.10.0 +module load ip/3.3.3 +module load nemsio/2.5.2 +module load sfcio/1.4.1 +module load sigio/2.3.2 +module load sp/2.3.3 +module load w3nco/2.4.1 +module load w3emc/2.7.3 +module load wrf_io/1.2.0 diff --git a/modulefiles/cheyenne_gnu b/modulefiles/cheyenne_gnu new file mode 100644 index 000000000..c7dbc8e18 --- /dev/null +++ b/modulefiles/cheyenne_gnu @@ -0,0 +1,41 @@ +#%Module# + +proc ModulesHelp { } { +puts stderr "Loads modules required for building upp" +} +module-whatis "Loads UPP prerequisites on Cheyenne for Intel 2021.2" + +module purge + +module load cmake/3.18.2 +module load ncarenv/1.3 +module load gnu/10.1.0 +module load mpt/2.22 +module load ncarcompilers/0.5.0 +module load python/3.7.9 +module unload netcdf + +module use /glade/p/ral/jntp/GMTB/tools/hpc-stack-v1.2.0/modulefiles/stack +module load hpc/1.2.0 +module load hpc-gnu/10.1.0 +module load hpc-mpt/2.22 + +module load jasper/2.0.25 +module load zlib/1.2.11 +module load png/1.6.35 + +module load hdf5/1.10.6 +module load netcdf/4.7.4 + +module load bacio/2.4.1 +module load crtm/2.3.0 +module load g2/3.4.2 +module load g2tmpl/1.10.0 +module load ip/3.3.3 +module load nemsio/2.5.2 +module load sfcio/1.4.1 +module load sigio/2.3.2 +module load sp/2.3.3 +module load w3nco/2.4.1 +module load w3emc/2.7.3 +module load wrf_io/1.2.0 diff --git a/sorc/ncep_post.fd/ALLOCATE_ALL.f b/sorc/ncep_post.fd/ALLOCATE_ALL.f index a9f19dfe4..5ae2b25a0 100644 --- a/sorc/ncep_post.fd/ALLOCATE_ALL.f +++ b/sorc/ncep_post.fd/ALLOCATE_ALL.f @@ -18,6 +18,7 @@ !! - 21-04-06 Wen Meng - Initializing all allocated arrays !! - 21-04-16 Wen Meng - Initializing aextc55 and extc55 as 0. These !! two arrays are involved in GSL visibility computation. +!! - 22-03-22 Wen Meng - Initializing pwat. !! !! OUTPUT FILES: !! - STDOUT - RUN TIME STANDARD OUT. @@ -970,6 +971,7 @@ SUBROUTINE ALLOCATE_ALL() 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 @@ -1020,6 +1022,7 @@ SUBROUTINE ALLOCATE_ALL() tedir(i,j)=spval twa(i,j)=spval fdnsst(i,j)=spval + pwat(i,j)=spval enddo enddo ! diff --git a/sorc/ncep_post.fd/CALDRG.f b/sorc/ncep_post.fd/CALDRG.f index 3d3d09278..352d6cf59 100644 --- a/sorc/ncep_post.fd/CALDRG.f +++ b/sorc/ncep_post.fd/CALDRG.f @@ -2,17 +2,20 @@ !> @brief Subroutine that computes drag cofficient. ! !> This rountine computes a surface layer drag coefficient using -!> equation (7.4.1A) in "An introduction to boundary layer -!> meteorology" by Stull (1988, Kluwer Academic Publishers). +!> equation (7.4.1A) in ["An introduction to boundary layer +!> meteorology" by Stull (1988, Kluwer Academic +!> Publishers)](https://link.springer.com/book/10.1007/978-94-009-3027-8). !> -!> @param[out] DRAGCO surface layer drag coefficient +!> @param[out] DRAGCO surface layer drag coefficient. !> -!> Program history -!> - 93-09-01 Russ Treadon -!> - 98-06-15 T Black - Conversion from 1-D to 2-D -!> - 00-01-04 Jim Tuccillo - MPI version -!> - 02-01-15 Mike Baldwin - WRF version -!> - 05-02-22 H Chuang - Add WRF NMM components +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-09-01 | Russ Treadon | Initial +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI version +!> 2002-01-15 | Mike Baldwin | WRF version +!> 2005-02-22 | H Chuang | Add WRF NMM components !> !> @author Russ Treadon W/NP2 @date 1993-09-01 SUBROUTINE CALDRG(DRAGCO) diff --git a/sorc/ncep_post.fd/CALDWP.f b/sorc/ncep_post.fd/CALDWP.f index 96e097326..02f309a94 100644 --- a/sorc/ncep_post.fd/CALDWP.f +++ b/sorc/ncep_post.fd/CALDWP.f @@ -1,21 +1,21 @@ !> @file !> @brief Subroutine related to dewpoint temperature. ! -!> Computes dewpoint from P, T, and Q +!> Computes dewpoint from P, T, and Q. !> -!> @param[in] P1D Pressure (Pa) -!> @param[in] Q1D Specific humidity (kg/kg) -!> @param[in] T1D Temperature (K) -!> @param[out] TDWP Dewpoint temperature (K) +!> @param[in] P1D Pressure (Pa). +!> @param[in] Q1D Specific humidity (kg/kg). +!> @param[in] T1D Temperature (K). +!> @param[out] TDWP Dewpoint temperature (K). !> -!> Program history -!> - 92-12-22 Russ Treadon -!> - 93-10-04 Russ Treadon - Added check to bound dewpoint -!> temperature to not exceed the -!> ambient temperature. -!> - 98-06-08 T BLACK - Conversion from 1-D to 2-D -!> - 00-01-04 Jim Tuccillo - MPI version -!> - 21-07-23 Wen Meng - Retrict computation from undefined points +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1993-10-04 | Russ Treadon | Added check to bound dewpoint temperature to not exceed the ambient temperature. +!> 1998-06-08 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI version +!> 2021-07-23 | Wen Meng | Retrict computation from undefined points !> !> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE CALDWP(P1D,Q1D,TDWP,T1D) diff --git a/sorc/ncep_post.fd/CALGUST.f b/sorc/ncep_post.fd/CALGUST.f index 0ba8eb498..cef7b692e 100644 --- a/sorc/ncep_post.fd/CALGUST.f +++ b/sorc/ncep_post.fd/CALGUST.f @@ -1,47 +1,22 @@ !> @file -! . . . -!> SUBPROGRAM: CALGUST COMPUTE MAX WIND LEVEL -!! PRGRMMR: MANIKIN ORG: W/NP2 DATE: 97-03-04 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES SURFACE WIND GUST BY MIXING -!! DOWN MOMENTUM FROM THE LEVEL AT THE HEIGHT OF THE PBL -!! -!! -!! PROGRAM HISTORY LOG: -!! 03-10-15 GEOFF MANIKIN -!! 05-03-09 H CHUANG - WRF VERSION -!! 05-07-07 BINBIN ZHOU - ADD RSM -!! 15-03-11 S Moorthi - set sfcwind to spval if u10 and v10 are spvals -!! for A grid and set gust to just wind -!! (in GSM with nemsio, it appears u10 & v10 have spval) -!! 21-09-02 Bo Cui - Decompose UPP in X direction -!! -!! USAGE: CALL CALGUST(GUST) -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! GUST - SPEED OF THE MAXIMUM SFC WIND GUST -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! H2V -!! -!! LIBRARY: -!! COMMON - -!! LOOPS -!! OPTIONS -!! MASKS -!! INDX -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes max wind level. +! +!> This routine computes surface wind gust by mixing +!> down momentum from the level at the height of the PBL. +!> +!> @param[out] GUST Speed of the maximum surface wind gust. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2003-10-15 | Geoff Manokin | Initial +!> 2005-03-09 | H Chuang | WRF Version +!> 2005-07-07 | Binbin Zhou | Add RSM +!> 2015-03-11 | S Moorthi | Set sfcwind to spval if u10 and v10 are spvals for A grid and set gust to just wind (in GSM with nemsio, it appears u10 & v10 have spval) +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Geoff Manikin W/NP2 @date 1997-03-04 + SUBROUTINE CALGUST(LPBL,ZPBL,GUST) ! diff --git a/sorc/ncep_post.fd/CALHEL.f b/sorc/ncep_post.fd/CALHEL.f index 8c11bc24c..a69c4260b 100644 --- a/sorc/ncep_post.fd/CALHEL.f +++ b/sorc/ncep_post.fd/CALHEL.f @@ -1,81 +1,44 @@ !> @file -! . . . -!> SUBPROGRAM: CALHEL COMPUTES STORM RELATIVE HELICITY -!! PRGRMMR: BALDWIN ORG: W/NP2 DATE: 94-08-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES ESTIMATED STORM MOTION AND -!! STORM-RELATIVE ENVIRONMENTAL HELICITY. -!! (DAVIES-JONES ET AL 1990) THE ALGORITHM PROCEEDS AS -!! FOLLOWS. -!! -!! THE STORM MOTION COMPUTATION NO LONGER EMPLOYS THE DAVIES AND -!! JOHNS (1993) METHOD WHICH DEFINED STORM MOTION AS 30 DEGREES TO -!! THE RIGHT OF THE 0-6 KM MEAN WIND AT 75% OF THE SPEED FOR MEAN -!! SPEEDS LESS THAN 15 M/S AND 20 DEGREES TO THE RIGHT FOR SPEEDS -!! GREATER THAN 15 M/S. INSTEAD, WE NOW USE THE DYNAMIC METHOD -!! (BUNKERS ET AL. 1998) WHICH HAS BEEN FOUND TO DO BETTER IN -!! CASES WITH 'NON-CLASSIC' HODOGRAPHS (SUCH AS NORTHWEST-FLOW -!! EVENTS) AND DO AS WELL OR BETTER THAN THE OLD METHOD IN MORE -!! CLASSIC SITUATIONS. -!! -!! PROGRAM HISTORY LOG: -!! 94-08-22 MICHAEL BALDWIN -!! 97-03-27 MICHAEL BALDWIN - SPEED UP CODE -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 00-01-10 G MANIKIN - CHANGED TO BUNKERS METHOD -!! 02-05-22 G MANIKIN - NOW ALLOW CHOICE OF COMPUTING -!! HELICITY OVER TWO DIFFERENT -!! (0-1 and 0-3 KM) DEPTHS -!! 03-03-25 G MANIKIN - MODIFIED CODE TO COMPUTE MEAN WINDS -!! USING ARITHMETIC AVERAGES INSTEAD OF -!! MASS WEIGHTING; DIFFERENCES ARE MINOR -!! BUT WANT TO BE CONSISTENT WITH THE -!! BUNKERS METHOD -!! 04-04-16 M PYLE - MINIMAL MODIFICATIONS, BUT PUT INTO -!! NMM WRFPOST CODE -!! 05=02-25 H CHUANG - ADD COMPUTATION FOR ARW A GRID -!! 05-07-07 BINBIN ZHOU - ADD RSM FOR A GRID -!! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT -!! 21-09-02 Bo Cui - Decompose UPP in X direction -!! -!! USAGE: CALHEL(UST,VST,HELI) -!! INPUT ARGUMENT LIST: -!! DPTH - DEPTH IN METERS OVER WHICH HELICITY SHOULD BE COMPUTED; -!! ALLOWS ONE TO DISTINGUISH 0-3 KM AND 0-1 KM VALUES -!! -!! OUTPUT ARGUMENT LIST: -!! UST - ESTIMATED U COMPONENT (M/S) OF STORM MOTION. -!! VST - ESTIMATED V COMPONENT (M/S) OF STORM MOTION. -!! HELI - STORM-RELATIVE HELICITY (M**2/S**2) -!! CRA -!! USHR1 - U COMPONENT (M/S) OF 0-1 KM SHEAR -!! VSHR1 - V COMPONENT (M/S) OF 0-1 KM SHEAR -!! USHR6 - U COMPONENT (M/S) OF 0-0.5 to 5.5-6.0 KM SHEAR -!! VSHR6 - V COMPONENT (M/S) OF 0-0.5 to 5.5-6.0 KM SHEAR -!! CRA - -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! -!! LIBRARY: -!! COMMON - VRBLS -!! LOOPS -!! PHYS -!! EXTRA -!! MASKS -!! OPTIONS -!! INDX -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : IBM SP -!! +!> @brief Subroutine that computes storm relative helicity. +! +!> This routine computes estimated storm motion and storm-relative +!> environmental helicity. (Davies-Jones et al 1990) the algorithm +!> processd as follows. +!> +!> The storm motion computation no longer employs the Davies and Johns (1993) +!> method which defined storm motion as 30 degress to the right of the 0-6 km +!> mean wind at 75% of the speed for mean speeds less than 15 m/s and 20 degrees +!> to the right for speeds greater than 15 m/s. Instead, we now use the dynamic +!> method (Bunkers et al. 1988) which has been found to do better in cases with +!> 'non-classic' hodographs (such as Northwest-flow events) and do as well or +!> better than the old method in more classic situations. +!> +!> @param[in] DPTH Depth in meters over whcih helicity should be computed; allows one to distinguish 0-3 km and 0-1 km values. +!> @param[out] UST Estimated U Component (m/s) Of Storm motion. +!> @param[out] VST Estimated V Component (m/s) Of Storm motion. +!> @param[out] HELI Storm-relative heliciry (m**2/s**2). +!> @param[out] USHR1 U Component (m/s) Of 0-1 km shear. +!> @param[out] VSHR1 V Component (m/s) Of 0-1 km shear. +!> @param[out] USHR6 U Component (m/s) Of 0-0.5 to 5.5-6.0 km shear. +!> @param[out] VSHR6 V Component (m/s) Of 0-0.5 to 5.5-6.0 km shear. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1994-08-22 | Michael Baldwin | Initial +!> 1997-03-27 | Michael Baldwin | Speed up code +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2000-01-10 | G Manikin | Changed to Bunkers method +!> 2002-05-22 | G Manikin | Now allow choice of computing helicity over two different (0-1 and 0-3 km) depths +!> 2003-03-25 | G Manikin | Modified code to compute mean winds using arithmetic averages instead of mass weighting; differences are minor but want to be consistent with the Bunkers method +!> 2004-04-16 | M Pyle | Minimal modifications but put into NMM WRFPOST code +!> 2005-02-25 | H Chuang | Add computation for ARW A grid +!> 2005-07-07 | Binbin Zhou | Add RSM for A grid +!> 2019-10-30 | Bo Cui | Remove "goto" statement +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Michael Baldwin W/NP2 @date 1994-08-22 SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) ! diff --git a/sorc/ncep_post.fd/CALHEL2.f b/sorc/ncep_post.fd/CALHEL2.f index 183ebcc2a..2c1bb8460 100644 --- a/sorc/ncep_post.fd/CALHEL2.f +++ b/sorc/ncep_post.fd/CALHEL2.f @@ -1,85 +1,47 @@ !> @file -! . . . -!> SUBPROGRAM: CALHEL COMPUTES STORM RELATIVE HELICITY -!! PRGRMMR: BALDWIN ORG: W/NP2 DATE: 94-08-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES ESTIMATED STORM MOTION AND -!! STORM-RELATIVE ENVIRONMENTAL HELICITY. -!! (DAVIES-JONES ET AL 1990) THE ALGORITHM PROCEEDS AS -!! FOLLOWS. -!! -!! THE STORM MOTION COMPUTATION NO LONGER EMPLOYS THE DAVIES AND -!! JOHNS (1993) METHOD WHICH DEFINED STORM MOTION AS 30 DEGREES TO -!! THE RIGHT OF THE 0-6 KM MEAN WIND AT 75% OF THE SPEED FOR MEAN -!! SPEEDS LESS THAN 15 M/S AND 20 DEGREES TO THE RIGHT FOR SPEEDS -!! GREATER THAN 15 M/S. INSTEAD, WE NOW USE THE DYNAMIC METHOD -!! (BUNKERS ET AL. 1998) WHICH HAS BEEN FOUND TO DO BETTER IN -!! CASES WITH 'NON-CLASSIC' HODOGRAPHS (SUCH AS NORTHWEST-FLOW -!! EVENTS) AND DO AS WELL OR BETTER THAN THE OLD METHOD IN MORE -!! CLASSIC SITUATIONS. -!! -!! PROGRAM HISTORY LOG: -!! 94-08-22 MICHAEL BALDWIN -!! 97-03-27 MICHAEL BALDWIN - SPEED UP CODE -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 00-01-10 G MANIKIN - CHANGED TO BUNKERS METHOD -!! 02-05-22 G MANIKIN - NOW ALLOW CHOICE OF COMPUTING -!! HELICITY OVER TWO DIFFERENT -!! (0-1 and 0-3 KM) DEPTHS -!! 03-03-25 G MANIKIN - MODIFIED CODE TO COMPUTE MEAN WINDS -!! USING ARITHMETIC AVERAGES INSTEAD OF -!! MASS WEIGHTING; DIFFERENCES ARE MINOR -!! BUT WANT TO BE CONSISTENT WITH THE -!! BUNKERS METHOD -!! 04-04-16 M PYLE - MINIMAL MODIFICATIONS, BUT PUT INTO -!! NMM WRFPOST CODE -!! 05=02-25 H CHUANG - ADD COMPUTATION FOR ARW A GRID -!! 05-07-07 BINBIN ZHOU - ADD RSM FOR A GRID -!! 19-09-03 J MENG - MODIFIED TO COMPUTE EFFECTIVE HELICITY -!! AND CRITICAL ANGLE -!! 21-09-02 Bo Cui - Decompose UPP in X direction -!! -!! USAGE: CALHEL(UST,VST,HELI) -!! INPUT ARGUMENT LIST: -!! LLOW - LOWER BOUND CAPE>=100 AND CINS>=-250 -!! LUPP - UPPER BOUND CAPE< 100 OR CINS< -250 -!! DPTH - DEPTH IN METERS OVER WHICH HELICITY SHOULD BE COMPUTED; -!! ALLOWS ONE TO DISTINGUISH 0-3 KM AND 0-1 KM VALUES -!! -!! OUTPUT ARGUMENT LIST: -!! UST - ESTIMATED U COMPONENT (M/S) OF STORM MOTION. -!! VST - ESTIMATED V COMPONENT (M/S) OF STORM MOTION. -!! HELI - STORM-RELATIVE HELICITY (M**2/S**2) -!! CANGLE - CRITICAL ANGLE -!! CRA -!! USHR1 - U COMPONENT (M/S) OF 0-1 KM SHEAR -!! VSHR1 - V COMPONENT (M/S) OF 0-1 KM SHEAR -!! USHR6 - U COMPONENT (M/S) OF 0-0.5 to 5.5-6.0 KM SHEAR -!! VSHR6 - V COMPONENT (M/S) OF 0-0.5 to 5.5-6.0 KM SHEAR -!! CRA - -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! -!! LIBRARY: -!! COMMON - VRBLS -!! LOOPS -!! PHYS -!! EXTRA -!! MASKS -!! OPTIONS -!! INDX -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : IBM SP -!! +!> @brief Subroutine that computes storm relative helicity. +! +!> This routine computes estimated storm motion and storm-relative +!> environmental helicity. (Davies-Jones et al 1990) the algorithm +!> processd as follows. +!> +!> The storm motion computation no longer employs the Davies and Johns (1993) +!> method which defined storm motion as 30 degress to the right of the 0-6 km +!> mean wind at 75% of the speed for mean speeds less than 15 m/s and 20 degrees +!> to the right for speeds greater than 15 m/s. Instead, we now use the dynamic +!> method (Bunkers et al. 1988) which has been found to do better in cases with +!> 'non-classic' hodographs (such as Northwest-flow events) and do as well or +!> better than the old method in more classic situations. +!> +!> @param[in] LLOW Lower bound CAPE>=100 and CINS>=-250. +!> @param[in] LUPP Upper bound CAPE< 100 or CINS< -250; allows one to distinguish 0-3 km and 0-1 km values. +!> @param[in] DPTH Depth in meters over whcih helicity should be computed; allows one to distinguish 0-3 km and 0-1 km values. +!> @param[out] UST Estimated U Component (m/s) Of Storm motion. +!> @param[out] VST Estimated V Component (m/s) Of Storm motion. +!> @param[out] HELI Storm-relative heliciry (m**2/s**2). +!> @param[out] CANGLE Critical angle. +!> @param[out] USHR1 U Component (m/s) Of 0-1 km shear. +!> @param[out] VSHR1 V Component (m/s) Of 0-1 km shear. +!> @param[out] USHR6 U Component (m/s) Of 0-0.5 to 5.5-6.0 km shear. +!> @param[out] VSHR6 V Component (m/s) Of 0-0.5 to 5.5-6.0 km shear. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1994-08-22 | Michael Baldwin | Initial +!> 1997-03-27 | Michael Baldwin | Speed up code +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2000-01-10 | G Manikin | Changed to Bunkers method +!> 2002-05-22 | G Manikin | Now allow choice of computing helicity over two different (0-1 and 0-3 km) depths +!> 2003-03-25 | G Manikin | Modified code to compute mean winds using arithmetic averages instead of mass weighting; differences are minor but want to be consistent with the Bunkers method +!> 2004-04-16 | M Pyle | Minimal modifications but put into NMM WRFPOST code +!> 2005-02-25 | H Chuang | Add computation for ARW A grid +!> 2005-07-07 | Binbin Zhou | Add RSM for A grid +!> 2019-09-03 | J Meng | Modified to compute effective helicity and critical angle +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Michael Baldwin W/NP2 @date 1994-08-22 SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) ! diff --git a/sorc/ncep_post.fd/CALHEL3.f b/sorc/ncep_post.fd/CALHEL3.f index 942011340..156911f17 100644 --- a/sorc/ncep_post.fd/CALHEL3.f +++ b/sorc/ncep_post.fd/CALHEL3.f @@ -1,84 +1,47 @@ !> @file -! . . . -!> SUBPROGRAM: CALHEL COMPUTES STORM RELATIVE HELICITY -!! PRGRMMR: BALDWIN ORG: W/NP2 DATE: 94-08-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES ESTIMATED STORM MOTION AND -!! STORM-RELATIVE ENVIRONMENTAL HELICITY. -!! (DAVIES-JONES ET AL 1990) THE ALGORITHM PROCEEDS AS -!! FOLLOWS. -!! -!! THE STORM MOTION COMPUTATION NO LONGER EMPLOYS THE DAVIES AND -!! JOHNS (1993) METHOD WHICH DEFINED STORM MOTION AS 30 DEGREES TO -!! THE RIGHT OF THE 0-6 KM MEAN WIND AT 75% OF THE SPEED FOR MEAN -!! SPEEDS LESS THAN 15 M/S AND 20 DEGREES TO THE RIGHT FOR SPEEDS -!! GREATER THAN 15 M/S. INSTEAD, WE NOW USE THE DYNAMIC METHOD -!! (BUNKERS ET AL. 1998) WHICH HAS BEEN FOUND TO DO BETTER IN -!! CASES WITH 'NON-CLASSIC' HODOGRAPHS (SUCH AS NORTHWEST-FLOW -!! EVENTS) AND DO AS WELL OR BETTER THAN THE OLD METHOD IN MORE -!! CLASSIC SITUATIONS. -!! -!! PROGRAM HISTORY LOG: -!! 94-08-22 MICHAEL BALDWIN -!! 97-03-27 MICHAEL BALDWIN - SPEED UP CODE -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 00-01-10 G MANIKIN - CHANGED TO BUNKERS METHOD -!! 02-05-22 G MANIKIN - NOW ALLOW CHOICE OF COMPUTING -!! HELICITY OVER TWO DIFFERENT -!! (0-1 and 0-3 KM) DEPTHS -!! 03-03-25 G MANIKIN - MODIFIED CODE TO COMPUTE MEAN WINDS -!! USING ARITHMETIC AVERAGES INSTEAD OF -!! MASS WEIGHTING; DIFFERENCES ARE MINOR -!! BUT WANT TO BE CONSISTENT WITH THE -!! BUNKERS METHOD -!! 04-04-16 M PYLE - MINIMAL MODIFICATIONS, BUT PUT INTO -!! NMM WRFPOST CODE -!! 05=02-25 H CHUANG - ADD COMPUTATION FOR ARW A GRID -!! 05-07-07 BINBIN ZHOU - ADD RSM FOR A GRID -!! 19-09-03 J MENG - MODIFIED TO COMPUTE EFFECTIVE HELICITY -!! AND CRITICAL ANGLE -!! 21-03-15 E COLON - CALHEL2 MODIFIED TO COMPUTE EFFECTIVE -!! RATHER THAN FIXED LAYER HELICITY -!! 21-09-02 Bo Cui - Decompose UPP in X direction - -!! USAGE: CALHEL3(UST,VST,HELI) -!! INPUT ARGUMENT LIST: -!! LLOW - LOWER BOUND CAPE>=100 AND CINS>=-250 -!! LUPP - UPPER BOUND CAPE< 100 OR CINS< -250 -!! -!! OUTPUT ARGUMENT LIST: -!! UST - ESTIMATED U COMPONENT (M/S) OF STORM MOTION. -!! VST - ESTIMATED V COMPONENT (M/S) OF STORM MOTION. -!! HELI - STORM-RELATIVE HELICITY (M**2/S**2) -!! CRA -!! USHR1 - U COMPONENT (M/S) OF 0-1 KM SHEAR -!! VSHR1 - V COMPONENT (M/S) OF 0-1 KM SHEAR -!! USHR6 - U COMPONENT (M/S) OF 0-0.5 to 5.5-6.0 KM SHEAR -!! VSHR6 - V COMPONENT (M/S) OF 0-0.5 to 5.5-6.0 KM SHEAR -!! CRA - -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! -!! LIBRARY: -!! COMMON - VRBLS -!! LOOPS -!! PHYS -!! EXTRA -!! MASKS -!! OPTIONS -!! INDX -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : IBM SP -!! +!> @brief Subroutine that computes storm relative helicity. +! +!> This routine computes estimated storm motion and storm-relative +!> environmental helicity. (Davies-Jones et al 1990) the algorithm +!> processd as follows. +!> +!> The storm motion computation no longer employs the Davies and Johns (1993) +!> method which defined storm motion as 30 degress to the right of the 0-6 km +!> mean wind at 75% of the speed for mean speeds less than 15 m/s and 20 degrees +!> to the right for speeds greater than 15 m/s. Instead, we now use the dynamic +!> method (Bunkers et al. 1988) which has been found to do better in cases with +!> 'non-classic' hodographs (such as Northwest-flow events) and do as well or +!> better than the old method in more classic situations. +!> +!> @param[in] LLOW Lower bound CAPE>=100 and CINS>=-250. +!> @param[in] LUPP Upper bound CAPE< 100 or CINS< -250; allows one to distinguish 0-3 km and 0-1 km values. +!> @param[out] UST Estimated U Component (m/s) Of Storm motion. +!> @param[out] VST Estimated V Component (m/s) Of Storm motion. +!> @param[out] HELI Storm-relative heliciry (m**2/s**2). +!> @param[out] CANGLE Critical angle. +!> @param[out] USHR1 U Component (m/s) Of 0-1 km shear. +!> @param[out] VSHR1 V Component (m/s) Of 0-1 km shear. +!> @param[out] USHR6 U Component (m/s) Of 0-0.5 to 5.5-6.0 km shear. +!> @param[out] VSHR6 V Component (m/s) Of 0-0.5 to 5.5-6.0 km shear. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1994-08-22 | Michael Baldwin | Initial +!> 1997-03-27 | Michael Baldwin | Speed up code +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2000-01-10 | G Manikin | Changed to Bunkers method +!> 2002-05-22 | G Manikin | Now allow choice of computing helicity over two different (0-1 and 0-3 km) depths +!> 2003-03-25 | G Manikin | Modified code to compute mean winds using arithmetic averages instead of mass weighting; differences are minor but want to be consistent with the Bunkers method +!> 2004-04-16 | M Pyle | Minimal modifications but put into NMM WRFPOST code +!> 2005-02-25 | H Chuang | Add computation for ARW A grid +!> 2005-07-07 | Binbin Zhou | Add RSM for A grid +!> 2019-09-03 | J Meng | Modified to compute effective helicity and critical angle +!> 2021-03-15 | E Colon | CALHEL2 modified to compute effective rather than fixed layer helicity +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Michael Baldwin W/NP2 @date 1994-08-22 SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) ! diff --git a/sorc/ncep_post.fd/CALLCL.f b/sorc/ncep_post.fd/CALLCL.f index 7652e6830..6cc377511 100644 --- a/sorc/ncep_post.fd/CALLCL.f +++ b/sorc/ncep_post.fd/CALLCL.f @@ -1,51 +1,33 @@ !> @file -! -!> SUBPROGRAM: CALLCL COMPUTES LCL HEIGHTS AND PRESSURE -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-03-15 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE LIFTING CONDENSATION LEVEL -!! PRESSURE AND HEIGHT IN EACH COLUMN AT MASS POINTS. -!! THE HEIGHT IS ABOVE GROUND LEVEL. THE EQUATION USED -!! TO FIND THE LCL PRESSURE IS FROM BOLTAN (1980,MWR) -!! AND IS THE SAME AS THAT USED IN SUBROUTINE CALCAPE. -!! -!! THIS ROUTINE IS A TEST VERSION. STILL TO BE RESOLVED -!! IS THE "BEST" PARCEL TO LIFT. -!! -!! PROGRAM HISTORY LOG: -!! 93-03-15 RUSS TREADON -!! 98-06-16 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-04-24 MIKE BALDWIN - WRF VERSION -!! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT -!! 21-07-28 W Meng - Restriction compuatation from undefined grids -!! 21-09-02 Bo Cui - Decompose UPP in X direction -!! -!! USAGE: CALL CALLCL(P1D,T1D,Q1D,PLCL,ZLCL) -!! INPUT ARGUMENT LIST: -!! P1D - ARRAY OF PARCEL PRESSURES (PA) -!! T1D - ARRAY OF PARCEL TEMPERATURES (K) -!! Q1D - ARRAY OF PARCEL SPECIFIC HUMIDITIES (KG/KG) -!! -!! OUTPUT ARGUMENT LIST: -!! PLCL - PARCEL PRESSURE AT LCL (PA) -!! ZLCL - PARCEL AGL HEIGHT AT LCL (M) -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - LOOPS -!! OPTIONS -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes LCL heights and pressure. +!> +!> This routine computes the lifting condensation level +!> pressure and height in each column at mass points. +!> The height is above ground level. The equation used +!> to find the LCL pressure is from Boltan (1980, MWR) +!> and is the same as that used in subroutine CALCAPE. +!> +!> This is a test version. Still to be resolved +!> is the "best" parcel to lift. +!> +!> @param[in] P1D Array of parcel pressures (Pa). +!> @param[in] T1D Array of parcel temperatures (K). +!> @param[in] Q1D Array of parcel specific humidities (kg/kg). +!> @param[out] PLCL Parcel Pressure at LCL (Pa). +!> @param[out] ZLCL Parcel AGL height at LCL (m). +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-03-15 | Russ Treadon | Initial +!> 1998-06-16 | T Black | Convesion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-04-24 | Mike Baldwin | WRF Version +!> 2019-10-30 | Bo Cui | Remove "GOTO" Statement +!> 2021-07-28 | W Meng | Restriction compuatation from undefined grids +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1993-03-15 SUBROUTINE CALLCL(P1D,T1D,Q1D,PLCL,ZLCL) ! diff --git a/sorc/ncep_post.fd/CALMCVG.f b/sorc/ncep_post.fd/CALMCVG.f index d2ec706e3..f61cfe7a1 100644 --- a/sorc/ncep_post.fd/CALMCVG.f +++ b/sorc/ncep_post.fd/CALMCVG.f @@ -1,55 +1,37 @@ !> @file -! -!> SUBPROGRAM: CALMCVG COMPUTES MOISTURE CONVERGENCE -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-01-22 -!! -!! ABSTRACT: -!! GIVEN SPECIFIC HUMIDITY, Q, AND THE U-V WIND COMPONENTS -!! THIS ROUTINE EVALUATES THE VECTOR OPERATION, -!! DEL DOT (Q*VEC) -!! WHERE, -!! DEL IS THE VECTOR GRADIENT OPERATOR, -!! DOT IS THE STANDARD DOT PRODUCT OPERATOR, AND -!! VEC IS THE VECTOR WIND. -!! MINUS ONE TIMES THE RESULTING SCALAR FIELD IS THE -!! MOISTURE CONVERGENCE WHICH IS RETURNED BY THIS ROUTINE. -!! -!! PROGRAM HISTORY LOG: -!! 93-01-22 RUSS TREADON -!! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-04-23 MIKE BALDWIN - WRF C-GRID VERSION -!! 05-07-07 BINBIN ZHOU - ADD RSM A GRID -!! 06-04-25 H CHUANG - BUG FIXES TO CORECTLY COMPUTE MC AT BOUNDARIES -!! 21-04-01 J MENG - COMPUTATION ON DEFINED POINTS ONLY -!! 21-09-02 B CUI - REPLACE EXCH_F to EXCH -!! 21-09-30 J MENG - 2D DECOMPOSITION -!! -!! USAGE: CALL CALMCVG(Q1D,U1D,V1D,QCNVG) -!! INPUT ARGUMENT LIST: -!! Q1D - SPECIFIC HUMIDITY AT P-POINTS (KG/KG) -!! U1D - U WIND COMPONENT (M/S) AT P-POINTS -!! V1D - V WIND COMPONENT (M/S) AT P-POINTS -!! -!! OUTPUT ARGUMENT LIST: -!! QCNVG - MOISTURE CONVERGENCE (1/S) AT P-POINTS -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - MASKS -!! DYNAM -!! OPTIONS -!! INDX -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes moisture convergence. +!> +!>
+!> Given specific humidity, Q, and the U-V wind components
+!> This routine evaluates the vector operation, 
+!>                  DEL DOT (Q*VEC)
+!> where,
+!>    DEL is the vector gradient operator,
+!>    DOT is the standard dot product operator, and
+!>    VEC is the vector wind.
+!> Minus one times the resulting scalar field is the 
+!> moisture convergence which is returned by this routine.
+!>
+!> +!> @param[in] Q1D - Specific humidity at P-points (kg/kg). +!> @param[in] U1D - U wind component (m/s) at P-points. +!> @param[in] V1D - V wind component (m/s) at P-points. +!> @param[out] QCNVG - Moisture convergence (1/s) at P-points. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-01-22 | Russ Treadon | Initial +!> 1998-06-08 | T Black | Conversion From 1-D To 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-04-23 | Mike Baldwin | WRF C-Grid Version +!> 2005-07-07 | Binbin Zhou | Add RSM A Grid +!> 2006-04-25 | H Chuang | Bug fixes to correctly compute MC at boundaries +!> 2021-04-01 | J Meng | Computation on defined points only +!> 2021-09-02 | B CUI | REPLACE EXCH_F to EXCH +!> 2021-09-30 | J MENG | 2D DECOMPOSITION +!> +!> @author Russ Treadon W/NP2 @date 1993-01-22 SUBROUTINE CALMCVG(Q1D,U1D,V1D,QCNVG) ! diff --git a/sorc/ncep_post.fd/CALMICT.f b/sorc/ncep_post.fd/CALMICT.f index e4998cc32..9bd053a8d 100644 --- a/sorc/ncep_post.fd/CALMICT.f +++ b/sorc/ncep_post.fd/CALMICT.f @@ -1,59 +1,38 @@ !> @file -! . . . -!> SUBPROGRAM: CALMIC COMPUTES HYDROMETEORS -!! PRGRMMR: JIN ORG: W/NP2 DATE: 01-08-14 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE MIXING RATIOS OF CLOUD WATER, -!! CLOUD ICE, RAIN, AND SNOW. THE CODE IS BASED ON SUBROUTINES -!! GSMDRIVE & GSMCOLUMN IN THE NMM MODEL. -!! -!! PROGRAM HISTORY LOG: -!! 01-08-14 YI JIN -!! 02-02-11 Brad Ferrier - Minor changes for consistency w/ NMM model -!! 04-11-10 Brad Ferrier - Removed cloud fraction algorithm -!! 04-11-17 H CHUANG - WRF VERSION -!! 14-03-11 B Ferrier - Created new & old versions of this subroutine -!! to process new & old versions of the microphysics -!! 21-09-02 Bo Cui - Decompose UPP in X direction -!! -!! USAGE: CALL CALMICT_new(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL -!! &, QW1,QI1,QR1,QS1,DBZ1,DBZR1,DBZI1,DBZC1) -!! INPUT ARGUMENT LIST: -!! P1D - PRESSURE (PA) -!! T1D - TEMPERATURE (K) -!! Q1D - SPECIFIC HUMIDITY (KG/KG) -!! C1D - TOTAL CONDENSATE (CWM, KG/KG) -!! FI1D - F_ice (fraction of condensate in form of ice) -!! FR1D - F_rain (fraction of liquid water in form of rain) -!! FS1D - F_RimeF ("Rime Factor", ratio of total ice growth -!! to deposition growth) -!! CUREFL - Radar reflectivity contribution from convection (mm**6/m**3) -!! -!! OUTPUT ARGUMENT LIST: -!! QW1 - CLOUD WATER MIXING RATIO (KG/KG) -!! QI1 - CLOUD ICE MIXING RATIO (KG/KG) -!! QR1 - RAIN MIXING RATIO (KG/KG) -!! QS1 - "SNOW" (precipitation ice) MIXING RATIO (KG/KG) -!! DBZ1 - Equivalent radar reflectivity factor in dBZ; i.e., 10*LOG10(Z) -!! DBZR - Equivalent radar reflectivity factor from rain in dBZ -!! DBZI - Equivalent radar reflectivity factor from ice (all forms) in dBZ -!! DBZC - Equivalent radar reflectivity factor from parameterized convection in dBZ -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! FUNCTIONS: -!! FPVS -!! UTILITIES: -!! LIBRARY: -!! NONE -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : IBM SP -!! +!> @brief Subroutine that computes hydrometeors. +!> +!> This routin computes the mixing ratios of cloud water, +!> cloud ice, rain, and snow. The code is based on subroutines +!> GSMDRIVE and GSMCOLUMN in the NMM model. +!> +!> @param[in] P1D Pressure (Pa). +!> @param[in] T1D Temperature (K). +!> @param[in] Q1D Specific humidity (kg/kg). +!> @param[in] C1D Total condensate (CWM, kg/kg). +!> @param[in] FI1D F_ice (fraction of condensate in form of ice). +!> @param[in] FR1D F_rain (fraction of liquid water in form of rain). +!> @param[in] FS1D F_RimeF ("Rime Factor", ratio of total ice growth to deposition growth). +!> @param[in] CUREFL Radar reflectivity contribution from convection (mm**6/m**3). +!> @param[out] QW1 Cloud water mixing ratio (kg/kg). +!> @param[out] QI1 Cloud ice mixing ratio (kg/kg). +!> @param[out] QR1 Rain mixing ratio (kg/kg). +!> @param[out] QS1 "Snow" (precipitation ice) mixing ratio (kg/kg). +!> @param[out] DBZ1 Equivalent radar reflectivity factor in dBZ; i.e., 10*LOG10(Z). +!> @param[out] DBZR Equivalent radar reflectivity factor from rain in dBZ. +!> @param[out] DBZI Equivalent radar reflectivity factor from ice (all forms) in dBZ. +!> @param[out] DBZC Equivalent radar reflectivity factor from parameterized convection in dBZ. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2001-08-14 | Yi Jin | Initial +!> 2002-02-11 | Brad Ferrier | Minor changes for consistency w/ NMM model +!> 2004-11-10 | Brad Ferrier | Removed cloud fraction algorithm +!> 2004-11-17 | H Chuang | WRF VERSION +!> 2014-03-11 | Brad Ferrier | Created new & old versions of this subroutine to process new & old versions of the microphysics +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Yi Jin W/NP2 @date 2001-08-14 SUBROUTINE CALMICT_new(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & QW1,QI1,QR1,QS1,DBZ1,DBZR1,DBZI1,DBZC1,NLICE1,NRAIN1) @@ -322,66 +301,39 @@ SUBROUTINE CALMICT_new(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & ! SUBROUTINE CALMICT_old(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & QW1,QI1,QR1,QS1,DBZ1,DBZR1,DBZI1,DBZC1,NLICE1,NRAIN1) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALMICT_old COMPUTES HYDROMETEORS FROM THE OLDER VERSION -! OF THE MICROPHYSICS -! -! PRGRMMR: JIN ORG: W/NP2 DATE: 01-08-14 -! -! ABSTRACT: -! THIS ROUTINE COMPUTES THE MIXING RATIOS OF CLOUD WATER, CLOUD ICE, -! RAIN, AND SNOW. THE CODE IS BASED ON OPTION MP_PHYSICS==95 IN THE -! WRF NAMELIST AND OPTION MICRO='fer' in NMMB CONFIGURE FILES. -! -! PROGRAM HISTORY LOG: -! 01-08-14 YI JIN -! 02-02-11 Brad Ferrier - Minor changes for consistency w/ NMM model -! 04-11-10 Brad Ferrier - Removed cloud fraction algorithm -! 04-11-17 H CHUANG - WRF VERSION -! 14-03-11 B Ferrier - Created new & old versions of this subroutine -! to process new & old versions of the microphysics -! -! USAGE: CALL CALMICT_old(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL -! &, QW1,QI1,QR1,QS1,DBZ1,DBZR1,DBZI1,DBZC1) -! -! INPUT ARGUMENT LIST: -! P1D - PRESSURE (PA) -! T1D - TEMPERATURE (K) -! Q1D - SPECIFIC HUMIDITY (KG/KG) -! C1D - TOTAL CONDENSATE (CWM, KG/KG) -! FI1D - F_ice (fraction of condensate in form of ice) -! FR1D - F_rain (fraction of liquid water in form of rain) -! FS1D - F_RimeF ("Rime Factor", ratio of total ice growth -! to deposition growth) -! CUREFL - Radar reflectivity contribution from convection (mm**6/m**3) -! -! OUTPUT ARGUMENT LIST: -! QW1 - CLOUD WATER MIXING RATIO (KG/KG) -! QI1 - CLOUD ICE MIXING RATIO (KG/KG) -! QR1 - RAIN MIXING RATIO (KG/KG) -! QS1 - "SNOW" (precipitation ice) MIXING RATIO (KG/KG) -! DBZ1 - Equivalent radar reflectivity factor in dBZ; i.e., 10*LOG10(Z) -! DBZR - Equivalent radar reflectivity factor from rain in dBZ -! DBZI - Equivalent radar reflectivity factor from ice (all forms) in dBZ -! DBZC - Equivalent radar reflectivity factor from parameterized convection -! in dBZ -! -! OUTPUT FILES: -! NONE -! -! SUBPROGRAMS CALLED: -! FUNCTIONS: -! FPVS -! UTILITIES: -! LIBRARY: -! NONE -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! MACHINE : IBM SP -!$$$ -! +!> CALMICT_old computes hydrometeors from the older version of the microphysics. +!> +!> This routin computes the mixing ratios of cloud water, cloud ice, +!> rain, and snow. The code is based on option MP_PHYSICS==95 in the +!> WRF namelist and option MICRO='fer' in NMMB configure files. +!> +!> @param[in] P1D Pressure (Pa). +!> @param[in] T1D Temperature (K). +!> @param[in] Q1D Specific humidity (kg/kg). +!> @param[in] C1D Total condensate (CWM, kg/kg). +!> @param[in] FI1D F_ice (fraction of condensate in form of ice). +!> @param[in] FR1D F_rain (fraction of liquid water in form of rain). +!> @param[in] FS1D F_RimeF ("Rime Factor", ratio of total ice growth to deposition growth). +!> @param[in] CUREFL Radar reflectivity contribution from convection (mm**6/m**3). +!> @param[out] QW1 Cloud water mixing ratio (kg/kg). +!> @param[out] QI1 Cloud ice mixing ratio (kg/kg). +!> @param[out] QR1 Rain mixing ratio (kg/kg). +!> @param[out] QS1 "Snow" (precipitation ice) mixing ratio (kg/kg). +!> @param[out] DBZ1 Equivalent radar reflectivity factor in dBZ; i.e., 10*LOG10(Z). +!> @param[out] DBZR Equivalent radar reflectivity factor from rain in dBZ. +!> @param[out] DBZI Equivalent radar reflectivity factor from ice (all forms) in dBZ. +!> @param[out] DBZC Equivalent radar reflectivity factor from parameterized convection in dBZ. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2001-08-14 | Yi Jin | Initial +!> 2002-02-11 | Brad Ferrier | Minor changes for consistency w/ NMM model +!> 2004-11-10 | Brad Ferrier | Removed cloud fraction algorithm +!> 2004-11-17 | H Chuang | WRF VERSION +!> 2014-03-11 | Brad Ferrier | Created new & old versions of this subroutine to process new & old versions of the microphysics +!> +!> @author Yi Jin W/NP2 @date 2001-08-14 use params_mod, only: dbzmin, epsq, tfrz, eps, rd, d608, oneps, nlimin use ctlblk_mod, only: jsta, jend, jsta_2l, jend_2u, im, & ista, iend, ista_2l, iend_2u diff --git a/sorc/ncep_post.fd/CALPBL.f b/sorc/ncep_post.fd/CALPBL.f index b3c6e0d20..015f4cd10 100644 --- a/sorc/ncep_post.fd/CALPBL.f +++ b/sorc/ncep_post.fd/CALPBL.f @@ -1,35 +1,18 @@ !> @file -! -!> SUBPROGRAM: CALPBL COMPUTES PBL HEIGHT BASED ON BULK RCH NUMBER -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE BULK RICHARDSON NUMBER -!! AND PBL HEIGHT ABOVE SURFACE -!! -!! PROGRAM HISTORY LOG: -!! 06-05-04 M TSIDULKO -!! 21-09-02 Bo Cui - Decompose UPP in X direction -!! -!! USAGE: CALL CALPBL(PBLRI) -!! INPUT ARGUMENT LIST: -!! -!! OUTPUT ARGUMENT LIST: -!! PBLRI - PBL HEIGHT ABOVE GROUND -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - -!! CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : -!! +!> @brief Subroutine that computes PBL height based on bulk RCH number. +!> +!> This routine computes the bulk Richardson number +!> and PBL height above surface. +!> +!> @param[out] PBLRI PBL height above ground. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2006-05-04 | M Tsidulko | Initial +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author M Tsidulko @date 2006-05-04 SUBROUTINE CALPBL(PBLRI) ! diff --git a/sorc/ncep_post.fd/CALPBLREGIME.f b/sorc/ncep_post.fd/CALPBLREGIME.f index 808bd274d..72c59616f 100644 --- a/sorc/ncep_post.fd/CALPBLREGIME.f +++ b/sorc/ncep_post.fd/CALPBLREGIME.f @@ -1,48 +1,30 @@ !> @file -! . . . -!> SUBPROGRAM: CALPBL COMPUTES PBL HEIGHT BASED ON BULK RCH NUMBER -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE BULK RICHARDSON NUMBER BASED ON ALGORITHMS -!! FROM WRF SURFACE LAYER AND THEN DERIVE PBL REGIME AS FOLLOWS: -!! 1. BR >= 0.2; -!! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), -!! -!! 2. BR < 0.2 .AND. BR > 0.0; -!! REPRESENTS DAMPED MECHANICAL TURBULENT CONDITIONS -!! (REGIME=2), -!! -!! 3. BR == 0.0 -!! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), -!! -!! 4. BR < 0.0 -!! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). -!! . -!! -!! PROGRAM HISTORY LOG: -!! 07-04-27 H CHUANG -!! 21-09-02 Bo Cui - Decompose UPP in X direction -!! -!! USAGE: CALL CALPBLREGIME(PBLREGIME) -!! INPUT ARGUMENT LIST: -!! -!! OUTPUT ARGUMENT LIST: -!! PBLRI - PBL HEIGHT ABOVE GROUND -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - -!! CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : -!! +!> @brief Subroutine that computes PBL height based on bulk RCH number. +!> +!> This routine computes the bulk Richardson number based on algorithms +!> from WRF surface layer and then derive PBL regime as follows: +!> 1. BR >= 0.2; +!> Represents nighttime stable conditions (Regime=1), +!> +!> 2. BR < 0.2 .AND. BR > 0.0; +!> Represents damped mechanical turbulent conditions +!> (Regime=2), +!> +!> 3. BR == 0.0 +!> Represents forced convection conditions (Regime=3), +!> +!> 4. BR < 0.0 +!> Represnets free convection conditions (Regime=4). +!> +!> @param[out] PBLRI PBL Height above ground. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2007-04-27 | H Chuang | Initial +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author H Chuang @date 2007-04-27 SUBROUTINE CALPBLREGIME(PBLREGIME) ! diff --git a/sorc/ncep_post.fd/CALPOT.f b/sorc/ncep_post.fd/CALPOT.f index c8d0885d4..ec5cd58c7 100644 --- a/sorc/ncep_post.fd/CALPOT.f +++ b/sorc/ncep_post.fd/CALPOT.f @@ -1,40 +1,23 @@ !> @file -! -!> SUBPROGRAM: CALPOT COMPUTES POTENTIAL TEMPERATURE -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-24 -!! -!! ABSTRACT: -!! GIVEN PRESSURE AND TEMPERATURE THIS ROUTINE RETURNS -!! THE POTENTIAL TEMPERATURE. -!! -!! PROGRAM HISTORY LOG: -!! 92-12-24 RUSS TREADON -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-04-24 MIKE BALDWIN - WRF VERSION -!! 21-09-02 Bo Cui - Decompose UPP in X direction -!! -!! USAGE: CALL CALPOT(P1D,T1D,THETA) -!! INPUT ARGUMENT LIST: -!! P1D - PRESSURE (PA) -!! T1D - TEMPERATURE (K) -!! -!! OUTPUT ARGUMENT LIST: -!! THETA - POTENTIAL TEMPERATURE (K) -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! NONE -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes potential temperature. +!> +!> Given pressure and temperature this routine returns +!> the potential temperature. +!> +!> @param[in] P1D pressures (Pa). +!> @param[in] T1D temperatures (K). +!> @param[out] THETA potential temperatures (K). +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-24 | Russ Treadon | Initial +!> 1998-06-15 | T Black | Convesion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-04-24 | Mike Baldwin | WRF Version +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1992-12-24 SUBROUTINE CALPOT(P1D,T1D,THETA) ! diff --git a/sorc/ncep_post.fd/CALPW.f b/sorc/ncep_post.fd/CALPW.f index a15c067fb..6db279e12 100644 --- a/sorc/ncep_post.fd/CALPW.f +++ b/sorc/ncep_post.fd/CALPW.f @@ -1,62 +1,43 @@ !> @file -! . . . -!> SUBPROGRAM: CALPW COMPUTES -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-24 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES PRECIPITABLE WATER IN A COLUMN -!! EXTENDING FROM THE FIRST ATMOSPHERIC ETA LAYER TO THE -!! MODEL TOP. THE DEFINITION USED IS -!! TOP -!! PRECIPITABLE WATER = SUM (Q+CLDW) DP*HTM/G -!! BOT -!! WHERE, -!! BOT IS THE FIRST ETA LAYER, -!! TOP IS THE MODEL TOP, -!! Q IS THE SPECIFIC HUMIDITY (KG/KG) IN THE LAYER -!! CLDW IS THE CLOUD WATER (KG/KG) IN THE LAYER -!! DP (Pa) IS THE LAYER THICKNESS. -!! HTM IS THE HEIGHT MASK AT THAT LAYER (=0 IF BELOW GROUND) -!! G IS THE GRAVITATIONAL CONSTANT -!! -!! PROGRAM HISTORY LOG: -!! 92-12-24 RUSS TREADON -!! 96-03-04 MIKE BALDWIN - ADD CLOUD WATER AND SPEED UP CODE -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-06-19 MIKE BALDWIN - WRF VERSION -!! 04-12-30 H CHUANG - UPDATE TO CALCULATE TOTAL COLUMN FOR OTHER -!! HYDROMETEORS -!! 14-11-12 SARAH LU - UPDATE TO CALCULATE AEROSOL OPTICAL DEPTH -!! 15-07-02 SARAH LU - UPDATE TO CALCULATE SCATTERING AEROSOL -!! OPTICAL DEPTH (18) -!! 15-07-04 SARAH LU - CORRECT PW INTEGRATION FOR AOD (17) -!! 15-07-10 SARAH LU - UPDATE TO CALCULATE ASYMETRY PARAMETER -!! 19-07-25 Li(Kate) Zhang - MERGE SARHA LU's update for FV3-Chem -!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE -!! 21-09-02 Bo Cui - Decompose UPP in X direction -!! -!! USAGE: CALL CALPW(PW) -!! INPUT ARGUMENT LIST: -!! PW - ARRAY OF PRECIPITABLE WATER. -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - LOOPS -!! MASKS -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes precipitable water. +!> +!>
+!> This routine computes precipitable water in a column
+!> extending from the first atmospheric ETA layer to the
+!> model top. The definition used is
+!>                      TOP
+!> precipitable water = sum (Q+CLDW) DP*HTM/G
+!>                      BOT
+!> where,
+!> BOT is the first ETA layer,
+!> TOP is the model top,
+!> Q is the specific humidity (kg/kg) in the layer
+!> CLDW is the cloud water (kg/kg) in the layer
+!> DP (Pa) is the layer thickness.
+!> HTM is the height mask at that layer (=0 if below ground)
+!> G is the gravitational constant.
+!>
+!> +!> @param[in] PW Array of precipitable water. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-24 | Russ Treadon | Initial +!> 1996-03-04 | Mike Baldwin | Add cloud water and speed up code +!> 1998-06-15 | T Black | Convesion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-06-19 | Mike Baldwin | WRF Version +!> 2004-12-30 | H Chuang | Update to calculate total column for other hydrometeors +!> 2014-11-12 | Sarah Lu | Update tp calculate aerosol optical depth +!> 2015-07-02 | Sarah Lu | Update to calculate scattering aerosal optical depth (18) +!> 2015-07-04 | Sarah Lu | Correct PW integration for AOD (17) +!> 2015-07-10 | Sarah Lu | Update to calculate asymetry parameter +!> 2019-07-25 | Li(Kate) Zhang | Merge Sarah Lu's update for FV3-Chem +!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS Module +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1992-12-24 SUBROUTINE CALPW(PW,IDECID) ! diff --git a/sorc/ncep_post.fd/CALRAD_WCLOUD_newcrtm.f b/sorc/ncep_post.fd/CALRAD_WCLOUD_newcrtm.f index 62d3d85bc..4a7c19e3d 100644 --- a/sorc/ncep_post.fd/CALRAD_WCLOUD_newcrtm.f +++ b/sorc/ncep_post.fd/CALRAD_WCLOUD_newcrtm.f @@ -1,31 +1,23 @@ !> @file -! -!> THIS ROUTINE COMPUTES MODEL DERIVED BRIGHTNESS TEMPERATURE -!! USING CRTM. IT IS PATTERNED AFTER GSI SETUPRAD WITH TREADON'S HELP -!! -!! PROGRAM HISTORY LOG: -!! - 11-02-06 Jun WANG - addgrib2 option -!! - 14-12-09 WM LEWIS ADDED: -!! FUNCTION EFFR TO COMPUTE EFFECTIVE PARTICLE RADII -!! CHANNEL SELECTION USING LVLS FROM WRF_CNTRL.PARM -!! - 19-04-01 Sharon NEBUDA - Added output option for GOES-16 & GOES-17 ABI IR Channels 7-16 -!! - 20-04-09 Tracy Hertneky - Added Himawari-8 AHI CH7-CH16 -!! - 21-01-10 Web Meng - Added checking points for skiping grids with filling value spval -!! - 21-03-11 Bo Cui - improve local arrays memory -!! - 21-08-31 Lin Zhu - added ssmis-f17 channels 15-18 grib2 output -!! - 21-09-02 Bo Cui - Decompose UPP in X direction -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! -!! LIBRARY: -!! /nwprod/lib/sorc/crtm2 -!! -!! @author CHUANG @date 07-01-17 -!! +!> @brief Subroutine that computes model derived brightness temperature. +!> +!> This routine computes model derived brightness temperature +!> using CRTM. It is patterned after GSI setuprad with Treadon's help. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2007-01-17 | H Chuang | Initial +!> 2011-02-06 | Jun Wang | add grib2 option +!> 2014-12-09 | WM Lewis | added function EFFR to compute effective particle radii channel selection using LVLS from WRF_CNTRL.PARM +!> 2019-04-01 | Sharon Nebuda | Added output option for GOES-16 & GOES-17 ABI IR Channels 7-16 +!> 2020-04-09 | Tracy Hertneky | Added Himawari-8 AHI CH7-CH16 +!> 2021-01-10 | Wen Meng | Added checking points for skiping grids with filling value spval +!> 2021-03-11 | Bo Cui | improve local arrays memory +!> 2021-08-31 | Lin Zhu | added ssmis-f17 channels 15-18 grib2 output +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Chuang @date 2007-01-17 SUBROUTINE CALRAD_WCLOUD use vrbls3d, only: o3, pint, pmid, t, q, qqw, qqi, qqr, f_rimef, nlice, nrain, qqs, qqg, & diff --git a/sorc/ncep_post.fd/CALRCH.f b/sorc/ncep_post.fd/CALRCH.f index e177112ac..b1b520aed 100644 --- a/sorc/ncep_post.fd/CALRCH.f +++ b/sorc/ncep_post.fd/CALRCH.f @@ -1,44 +1,26 @@ !> @file -! -!> SUBPROGRAM: CALRCH COMPUTES GRD RCH NUMBER -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-10-11 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE GRADIENT RICHARDSON NUMBER -!! AS CODED IN ETA MODEL SUBROUTINE PROFQ2.F. -!! FIX TO AVOID UNREASONABLY SMALL ANEMOMETER LEVEL WINDS. -!! -!! PROGRAM HISTORY LOG: -!! 93-10-11 RUSS TREADON -!! 98-06-17 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 01-10-22 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-01-15 MIKE BALDWIN - WRF VERSION -!! 05-02-25 H CHUANG - ADD COMPUTATION FOR NMM E GRID -!! 05-07-07 BINBIN ZHOU - ADD RSM FOR A GRID -!! 21-09-02 Bo Cui - Decompose UPP in X direction -!! -!! USAGE: CALL CALRCH(EL,RICHNO) -!! INPUT ARGUMENT LIST: -!! EL - MIXING LENGTH SCALE. -!! -!! OUTPUT ARGUMENT LIST: -!! RICHNO - GRADIENT RICHARDSON NUMBER. -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - -!! CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes GRD RCH number. +!> +!> This routine computes the gradient Richardson number +!> as coded in ETA model subroutine PROFQ2.F. +!> Fix to avoid unreasonably small anemometer level winds. +!> +!> @param[in] EL Mixing length scale. +!> @param[out] RICHNO Gradient Richardson number. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-10-11 | Russ Treadon | Initial +!> 1998-06-17 | T Black | Convesion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2001-10-22 | H Chuang | Modified to process hybrid model output +!> 2002-01-15 | Mike Baldwin | WRF Version +!> 2005-02-25 | H Chuang | Add computation for NMM E grid +!> 2005-07-07 | Binbin Zhou | Add RSM for A Grid +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1993-10-11 SUBROUTINE CALRCH(EL,RICHNO) ! diff --git a/sorc/ncep_post.fd/CALSTRM.f b/sorc/ncep_post.fd/CALSTRM.f index c99390e52..adf7ac43e 100644 --- a/sorc/ncep_post.fd/CALSTRM.f +++ b/sorc/ncep_post.fd/CALSTRM.f @@ -1,44 +1,27 @@ !> @file -! -!> SUBPROGRAM: CALSTRM COMPUTES GEO STREAMFUNCTION -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE GEOSTROPHIC STREAMFUNCTION, -!! PSI, FROM THE PASSED GEOPOTENTIAL HEIGHT FIELD, Z. -!! THE FORMULA USED IS PSI = G*Z/F0, WHERE G IS THE -!! GRAVITATIONAL ACCELERATION CONSTANT AND F0 IS A -!! CONSTANT CORIOLIS PARAMETER. F0 IS SET TO BE THE -!! VALUE OF THE CORIOLIS PARAMETER NEAR THE CENTER -!! OF THE MODEL GRID. -!! -!! PROGRAM HISTORY LOG: -!! 92-12-22 RUSS TREADON -!! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-05 JIM TUCCILLO - MPI VERSION -!! 02-06-13 MIKE BALDWIN - WRF VERSION -!! 21-09-02 Bo Cui - Decompose UPP in X direction -!! -!! USAGE: CALL CALSTRM(Z1D,STRM) -!! INPUT ARGUMENT LIST: -!! Z1D - GEOPOTENTIAL HEIGHT (M) -!! -!! OUTPUT ARGUMENT LIST: -!! STRM - GEOSTROPHIC STREAMFUNCTION -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - MAPOT -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes geo streamfunction. +!> +!> This routine computes the geostrophic streamfunction, +!> PSI, from the passed geopotential height field, Z. +!> The formule used it PSI = G*Z/F0, where G is the +!> gravitational acceleration constant and F0 is a +!> constant Coriolis parameter. F0 is set to be the +!> valus of the Coriolis parameter near the center +!> of the model grid. +!> +!> @param[in] Z1D Geopotential height (m). +!> @param[out] STRM Geostrophic streamfunction. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1998-06-08 | T Black | Conversion from 1-D TO 2-D +!> 2000-01-05 | Jim Tuccillo | MPI Version +!> 2002-06-13 | Mike Baldwin | WRF Version +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE CALSTRM(Z1D,STRM) ! diff --git a/sorc/ncep_post.fd/CALTAU.f b/sorc/ncep_post.fd/CALTAU.f index d9f36302c..08338039d 100644 --- a/sorc/ncep_post.fd/CALTAU.f +++ b/sorc/ncep_post.fd/CALTAU.f @@ -1,47 +1,30 @@ !> @file -! -!> SUBPROGRAM: CALTAU COMPUTE U AND V WIND STRESSES -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-09-01 -!! -!! ABSTRACT: THIS ROUTINE COMPUTES SURFACE LAYER U AND V -!! WIND COMPONENT STRESSES USING K THEORY AS PRESENTED -!! IN SECTION 8.4 OF "NUMBERICAL PREDICTION AND DYNAMIC -!! METEOROLOGY" BY HALTINER AND WILLIAMS (1980, JOHN WILEY -!! & SONS). -!! -!! PROGRAM HISTORY LOG: -!! 93-09-01 RUSS TREADON -!! 98-06-11 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID OUTPUT -!! 02-01-15 MIKE BALDWIN - WRF VERSION, OUTPUT IS ON MASS-POINTS -!! 05-02-23 H CHUANG - COMPUTE STRESS FOR NMM ON WIND POINTS -!! 05-07-07 BINBIN ZHOU - ADD RSM STRESS for A GRID -!! 21-07-26 W Meng - Restrict computation from undefined grids -!! 21-09-02 Bo Cui - Decompose UPP in X direction -!! USAGE: CALL CALTAU(TAUX,TAUY) -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! TAUX - SUFACE LAYER U COMPONENT WIND STRESS. -!! TAUY - SUFACE LAYER V COMPONENT WIND STRESS. -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! CLMAX -!! MIXLEN -!! -!! LIBRARY: -!! COMMON - -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes U and V wind stresses. +!> +!> This routine computes surface layer U and V +!> wind component stresses using K theory as presented +!> in section 8.4 of "Numerical prediction and dynamic +!> meteorology" by Haltiner and Williams (1980, John Wiley +!> & Sons). +!> +!> @param[out] TAUX Suface layer U component wind stress. +!> @param[out] TAUY Suface layer V component wind stress. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-09-01 | Russ Treadon | Initial +!> 1998-06-11 | T Black | Convesion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2001-10-25 | H Chuang | Modified to process hybrid output +!> 2002-01-15 | Mike Baldwin | WRF Version, output is on mass-points +!> 2005-02-23 | H Chuang | Compute stress for NMM on wind points +!> 2005-07-07 | Binbin Zhou | Add RSM stress for A Grid +!> 2021-07-26 | W Meng | Restrict computation from undefined grids +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1993-09-01 + SUBROUTINE CALTAU(TAUX,TAUY) ! diff --git a/sorc/ncep_post.fd/CALTHTE.f b/sorc/ncep_post.fd/CALTHTE.f index 96d1540b4..dae86a8a9 100644 --- a/sorc/ncep_post.fd/CALTHTE.f +++ b/sorc/ncep_post.fd/CALTHTE.f @@ -1,42 +1,26 @@ !> @file -! -!> SUBPROGRAM: CALTHTE COMPUTES THETA-E -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-06-18 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE EQUIVALENT POTENTIAL TEMPERATURE -!! GIVEN PRESSURE, TEMPERATURE, AND SPECIFIC HUMIDITY. THE -!! EQUATIONS OF BOLTON (MWR,1980) ARE USED. -!! -!! PROGRAM HISTORY LOG: -!! 93-06-18 RUSS TREADON -!! 98-06-16 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 21-07-28 W Meng - Restrict computation from undefined grids -!! 21-09-02 Bo Cui - Decompose UPP in X direction -!! -!! USAGE: CALL CALTHTE(P1D,T1D,Q1D,THTE) -!! INPUT ARGUMENT LIST: -!! P1D - PRESSURE (PA) -!! T1D - TEMPERATURE (K) -!! Q1D - SPECIFIC HUMIDITY (KG/KG) -!! -!! OUTPUT ARGUMENT LIST: -!! THTE - THETA-E (K) -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! VAPOR - FUNCTION TO CALCULATE VAPOR PRESSURE. -!! LIBRARY: -!! NONE -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes Theta-E. +!> +!> This routine computes the equivalent potential temperature +!> given pressure, temperature, and specific humidity. The +!> equations of Bolton (MWR,1980) are used. +!> +!> @param[in] P1D pressure (Pa). +!> @param[in] T1D temperature (K). +!> @param[in] Q1D specific humidity(kg/kg). +!> @param[out] THTE Theta-E (K). +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-06-18 | Russ Treadon | Initial +!> 1998-06-16 | T Black | Convesion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2021-07-28 | W Meng | Restrict computation from undefined grids +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1993-06-18 + SUBROUTINE CALTHTE(P1D,T1D,Q1D,THTE) ! diff --git a/sorc/ncep_post.fd/CALUPDHEL.f b/sorc/ncep_post.fd/CALUPDHEL.f index ff9704506..17ee6b81c 100644 --- a/sorc/ncep_post.fd/CALUPDHEL.f +++ b/sorc/ncep_post.fd/CALUPDHEL.f @@ -1,39 +1,19 @@ !> @file -! -!> SUBPROGRAM: CALUPDHEL COMPUTES UPDRAFT HELICITY -!! PRGRMMR: PYLE ORG: W/NP2 DATE: 07-10-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE UPDRAFT HELICITY -!! -!! PROGRAM HISTORY LOG: -!! 07-10-22 M PYLE - based on SPC Algorithm courtesy of David Bright -!! 11-01-11 M Pyle - converted to F90 for unified post -!! 11-04-05 H Chuang - added B grid option -!! 20-11-06 J Meng - USE UPP_MATH MODULE -!! 21-10-31 J Meng - 2D DECOMPOSITION -!! -!! USAGE: CALL CALUPDHEL(UPDHEL) -!! -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! UPDHEL - UPDRAFT HELICITY (M^2/S^2) -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes the updraft helicity. +!> +!> @param[out] UPDHEL Updraft helicity (m^2/s^2). +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2007-10-22 | M Pyle | Initial +!> 2007-10-22 | M Pyle | based on SPC Algorithm courtesy of David Bright +!> 2011-01-11 | M Pyle | converted to F90 for unified post +!> 2011-04-05 | H Chuang | added B grid option +!> 2020-11-06 | J Meng | Use UPP_MATH Module +!> 2021-10-31 | J Meng | 2D DECOMPOSITION +!> +!> @author M Pyle W/NP2 @date 2007-10-22 SUBROUTINE CALUPDHEL(UPDHEL) ! diff --git a/sorc/ncep_post.fd/CALWXT_BOURG.f b/sorc/ncep_post.fd/CALWXT_BOURG.f index 230b34de5..51fb0a3d0 100644 --- a/sorc/ncep_post.fd/CALWXT_BOURG.f +++ b/sorc/ncep_post.fd/CALWXT_BOURG.f @@ -1,69 +1,55 @@ !> @file -! -!> Subprogram: calwxt_bourg Calculate precipitation type (Bourgouin) -!! Prgmmr: Baldwin Org: np22 Date: 1999-07-06 -!! -!! Abstract: This routine computes precipitation type -!! using a decision tree approach that uses the so-called -!! "energy method" of Bourgouin of AES (Canada) 1992 -!! -!! Program history log: -!! 1999-07-06 M Baldwin -!! 1999-09-20 M Baldwin make more consistent with bourgouin (1992) -!! 2005-08-24 G Manikin added to wrf post -!! 2007-06-19 M Iredell mersenne twister, best practices -!! 2015-00-00 S Moorthi changed random number call and optimization and cleanup -!! 2021-10-31 J Meng 2D DECOMPOSITION -!! -!! Usage: call calwxt_bourg(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & -!! & iseed,g,pthresh, & -!! & t,q,pmid,pint,lmh,prec,zint,ptype) -!! Input argument list: -!! im integer i dimension -!! jm integer j dimension -!! jsta_2l integer j dimension start point (including haloes) -!! jend_2u integer j dimension end point (including haloes) -!! jsta integer j dimension start point (excluding haloes) -!! jend integer j dimension end point (excluding haloes) -!! lm integer k dimension -!! lp1 integer k dimension plus 1 -!! iseed integer random number seed -!! g real gravity (m/s**2) -!! pthresh real precipitation threshold (m) -!! t real(im,jsta_2l:jend_2u,lm) mid layer temp (K) -!! q real(im,jsta_2l:jend_2u,lm) specific humidity (kg/kg) -!! pmid real(im,jsta_2l:jend_2u,lm) mid layer pressure (Pa) -!! pint real(im,jsta_2l:jend_2u,lp1) interface pressure (Pa) -!! lmh real(im,jsta_2l:jend_2u) max number of layers -!! prec real(im,jsta_2l:jend_2u) precipitation (m) -!! zint real(im,jsta_2l:jend_2u,lp1) interface height (m) -!! Output argument list: -!! ptype integer(im,jm) instantaneous weather type () -!! acts like a 4 bit binary -!! 1111 = rain/freezing rain/ice pellets/snow -!! where the one's digit is for snow -!! the two's digit is for ice pellets -!! the four's digit is for freezing rain -!! and the eight's digit is for rain -!! in other words... -!! ptype=1 snow -!! ptype=2 ice pellets/mix with ice pellets -!! ptype=4 freezing rain/mix with freezing rain -!! ptype=8 rain -!! -!! Modules used: -!! mersenne_twister pseudo-random number generator -!! -!! Subprograms called: -!! random_number pseudo-random number generator -!! -!! Attributes: -!! Language: Fortran 90 -!! -!! Remarks: vertical order of arrays must be layer 1 = top -!! and layer lmh = bottom -!! -!! +!> @brief Subroutine that calculate precipitation type (Bourgouin). +!> +!> This routine computes precipitation type. +!> using a decision tree approach that uses the so-called +!> "energy method" of Bourgouin of AES (Canada) 1992. +!> +!> @param[in] im integer i dimension. +!> @param[in] jm integer j dimension. +!> @param[in] jsta_2l integer j dimension start point (including haloes). +!> @param[in] jend_2u integer j dimension end point (including haloes). +!> @param[in] jsta integer j dimension start point (excluding haloes). +!> @param[in] jend integer j dimension end point (excluding haloes). +!> @param[in] lm integer k dimension. +!> @param[in] lp1 integer k dimension plus 1. +!> @param[in] iseed integer random number seed. +!> @param[in] g real gravity (m/s**2). +!> @param[in] pthresh real precipitation threshold (m). +!> @param[in] t real(im,jsta_2l:jend_2u,lm) mid layer temp (K). +!> @param[in] q real(im,jsta_2l:jend_2u,lm) specific humidity (kg/kg). +!> @param[in] pmid real(im,jsta_2l:jend_2u,lm) mid layer pressure (Pa). +!> @param[in] pint real(im,jsta_2l:jend_2u,lp1) interface pressure (Pa). +!> @param[in] lmh real(im,jsta_2l:jend_2u) max number of layers. +!> @param[in] prec real(im,jsta_2l:jend_2u) precipitation (m). +!> @param[in] zint real(im,jsta_2l:jend_2u,lp1) interface height (m). +!> @param[out] ptype integer(im,jm) instantaneous weather type () acts like a 4 bit binary 1111 = rain/freezing rain/ice pellets/snow. +!>
+!>                   where the one's digit is for snow
+!>                         the two's digit is for ice pellets
+!>                         the four's digit is for freezing rain
+!>                         and the eight's digit is for rain
+!>                         in other words...
+!>                         ptype=1 snow
+!>                         ptype=2 ice pellets/mix with ice pellets
+!>                         ptype=4 freezing rain/mix with freezing rain
+!>                         ptype=8 rain
+!>
+!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-07-06 | M Baldwin | Initial +!> 1999-09-20 | M Baldwin | make more consistent with bourgouin (1992) +!> 2005-08-24 | G Manikin | added to wrf post +!> 2007-06-19 | M Iredell | mersenne twister, best practices +!> 2015-??-?? | S Moorthi | changed random number call and optimization and cleanup +!> 2021-10-31 | J Meng | 2D DECOMPOSITION +!> +!> Remarks: vertical order of arrays must be layer 1 = top +!> and layer lmh = bottom +!> +!> @author M Baldwin np22 @date 1999-07-06 subroutine calwxt_bourg_post(im,ista_2l,iend_2u,ista,iend,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & & iseed,g,pthresh, & diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index 422caf06a..eeb3e2c9b 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -1,99 +1,70 @@ !> @file -! . . . -!> SUBPROGRAM: CLDRAD POST SNDING/CLOUD/RADTN FIELDS -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-08-30 -!! -!! ABSTRACT: THIS ROUTINE COMPUTES/POSTS SOUNDING, CLOUD -!! RELATED, AND RADIATION FIELDS. UNDER THE HEADING OF -!! SOUNDING FIELDS FALL THE THREE ETA MODEL LIFTED INDICES, -!! CAPE, CIN, AND TOTAL COLUMN PRECIPITABLE WATER. -!! -!! THE THREE ETA MODEL LIFTED INDICES DIFFER ONLY IN THE -!! DEFINITION OF THE PARCEL TO LIFT. ONE LIFTS PARCELS FROM -!! THE LOWEST ABOVE GROUND ETA LAYER. ANOTHER LIFTS MEAN -!! PARCELS FROM ANY OF NBND BOUNDARY LAYERS (SEE SUBROUTINE -!! BNDLYR). THE FINAL TYPE OF LIFTED INDEX IS A BEST LIFTED -!! INDEX BASED ON THE NBND BOUNDARY LAYER LIFTED INDICES. -!! -!! TWO TYPES OF CAPE/CIN ARE AVAILABLE. ONE IS BASED ON PARCELS -!! IN THE LOWEST ETA LAYER ABOVE GROUND. THE OTHER IS BASED -!! ON A LAYER MEAN PARCEL IN THE N-TH BOUNDARY LAYER ABOVE -!! THE GROUND. SEE SUBROUTINE CALCAPE FOR DETAILS. -!! -!! THE CLOUD FRACTION AND LIQUID CLOUD WATER FIELDS ARE DIRECTLY -!! FROM THE MODEL WITH MINIMAL POST PROCESSING. THE LIQUID -!! CLOUD WATER, 3-D CLOUD FRACTION, AND TEMPERATURE TENDENCIES -!! DUE TO PRECIPITATION ARE NOT POSTED IN THIS ROUTINE. SEE -!! SUBROUTINE ETAFLD FOR THESE FIELDS. LIFTING CONDENSATION -!! LEVEL HEIGHT AND PRESSURE ARE COMPUTED AND POSTED IN -!! SUBROUTINE MISCLN. -!! -!! THE RADIATION FIELDS POSTED BY THIS ROUTINE ARE THOSE COMPUTED -!! DIRECTLY IN THE MODEL. -!! -!! PROGRAM HISTORY LOG: -!! 93-08-30 RUSS TREADON -!! 94-08-04 MICHAEL BALDWIN - ADDED OUTPUT OF INSTANTANEOUS SFC -!! FLUXES OF NET SW AND LW DOWN RADIATION -!! 97-04-25 MICHAEL BALDWIN - FIX PDS FOR PRECIPITABLE WATER -!! 97-04-29 GEOFF MANIKIN - MOVED CLOUD TOP TEMPS CALCULATION -!! TO THIS SUBROUTINE. CHANGED METHOD -!! OF DETERMINING WHERE CLOUD BASE AND -!! TOP ARE FOUND AND ADDED HEIGHT OPTION -!! FOR TOP AND BASE. -!! 98-04-29 GEOFF MANIKIN - CHANGED VALUE FOR CLOUD BASE/TOP PRESSURES -!! AND HEIGHTS FROM SPVAL TO -500 -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 98-07-17 MIKE BALDWIN - REMOVED LABL84 -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 00-02-22 GEOFF MANIKIN - CHANGED VALUE FOR CLOUD BASE/TOP PRESSURES -!! AND HEIGHTS FROM SPVAL TO -500 (WAS NOT IN -!! PREVIOUS IBM VERSION) -!! 01-10-22 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-01-15 MIKE BALDWIN - WRF VERSION -!! 05-01-06 H CHUANG - ADD VARIOUS CLOUD FIELDS -!! 05-07-07 BINBIN ZHOU - ADD RSM MODEL -!! 05-08-30 BINBIN ZHOU - ADD CEILING and FLIGHT CONDITION RESTRICTION -!! 10-09-09 GEOFF MANIKIN - REVISED CALL TO CALCAPE -!! 11-02-06 Jun Wang - ADD GRIB2 OPTION -!! 11-12-14 SARAH LU - ADD AEROSOL OPTICAL PROPERTIES -!! 11-12-16 SARAH LU - ADD AEROSOL 2D DIAG FIELDS -!! 11-12-23 SARAH LU - CONSOLIDATE ALL GOCART FIELDS TO BLOCK 4 -!! 11-12-23 SARAH LU - ADD AOD AT ADDITIONAL CHANNELS -!! 12-04-03 Jun Wang - Add lftx and GFS convective cloud cover for grib2 -!! 13-05-06 Shrinivas Moorthi - Add cloud condensate to total precip water -!! 13-12-23 LU/Wang - READ AEROSOL OPTICAL PROPERTIES LUTS to compute dust aod, -!! non-dust aod, and use geos5 gocart LUTS -!! 15-??-?? S. Moorthi - threading, optimization, local dimension -!! 19-07-24 Li(Kate) Zhang Merge and update ARAH Lu's work from NGAC into FV3-Chem -!! 19-10-30 Bo CUI - Remove "GOTO" statement -!! 20-03-25 Jesse Meng - remove grib1 -!! 20-05-20 Jesse Meng - CALRH unification with NAM scheme -!! 20-11-10 Jesse Meng - USE UPP_PHYSICS MODULE -!! 21-02-08 Anning Cheng, read aod550, aod550_du/su/ss/oc/bc -!! directly from fv3gfs and output to grib2 by setting rdaod -!! 21-04-01 Jesse Meng - COMPUTATION ON DEFINED POINTS ONLY -!! -!! USAGE: CALL CLDRAD -!! INPUT ARGUMENT LIST: -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - RQSTFLD -!! CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : IBM SP -!! +!> @brief Subroutine that post SNDING/CLOUD/RADTN fields. +!> +!> This routine computes/posts sounding cloud +!> related, and radiation fields. Under the heading of +!> sounding fields fall the three ETA model lifted indices, +!> CAPE, CIN, and total column precipitable water. +!> +!> The three ETA model lifted indices differ only in the +!> definition of the parcel to lift. One lifts parcels from +!> the lowest above ground ETA layer. Another lifts mean +!> parcels from any of NBND boundary layers (See subroutine +!> BNDLYR). The final type of lifted index is a best lifted +!> inden based on the NBND bouddary layer lifted indices. +!> +!> Two types of CAPE/CIN are available. One is based on parcels +!> in the lowest ETA layer above ground. The other is based +!> on a layer mean parcel in the N-th boundary layer above +!> the ground. See subroutine CALCAPE for details. +!> +!> The cloud fraction and liquid cloud water fields are directly +!> from the model with minimal post processing. The liquid +!> cloud water, 3-D cloud fraction, and temperature tendencies +!> due to precipotation are not posted in this routine. See +!> sunroutine ETAFLD for these fields. Lifting condensation +!> level height and pressure are computed and posted in +!> subroutine MISCLN. +!> +!> The radiation fields posted by this routine are those computed +!> directly in the model. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-08-30 | Russ Treadon | Initial +!> 1994-08-04 | Mike Baldwin | Added output of instantaneous SFC fluxes of net SW and LW down radiation +!> 1997-04-25 | Mike Baldwin | Fix PDS for precipitable water +!> 1997-04-29 | Geoff Manikin | Moved cloud top temps calculation to this subroutine. Changed method of determining where cloud base and top are found and added height option for top and base +!> 1998-04-29 | Geoff Manikin | Changed value for cloud base/top pressures and heights from SPVAL to -500 +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 1998-07-17 | Mike Baldwin | Removed LABL84 +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2000-02-22 | Geoff Manikin | Changed value for cloud base/top pressures and heights from SPVAL to -500 (was not in previous IBM version) +!> 2001-10-22 | H Chuang | Modified to process hybrid model output +!> 2002-01-15 | Mike Baldwin | WRF version +!> 2005-01-06 | H Chuang | Add various cloud fields +!> 2005-07-07 | Binbin Zhou | Add RSM model +!> 2005-08-30 | Binbin Zhou | Add ceiling and flight condition restriction +!> 2010-09-09 | Geoff Manikin | Revised call to CALCAPE +!> 2011-02-06 | Jun Wang | Add GRIB2 Option +!> 2011-12-14 | Sarah Lu | Add Aerosol optical properties +!> 2011-12-16 | Sarah Lu | Add Aerosol 2D DIAG fields +!> 2011-12-23 | Sarah Lu | Consolidate all GOCART fields to BLOCK 4 +!> 2011-12-23 | Sarah Lu | Add AOD at additional channels +!> 2012-04-03 | Jun Wang | Add lftx and GFS convective cloud cover for grib2 +!> 2013-05-06 | Shrinivas Moorthi | Add cloud condensate to total precip water +!> 2013-12-23 | Lu/Wang | Read aerosol optical properties LUTS to compute dust aod, non-dust aod, and use geos5 gocart LUTS +!> 2015-??-?? | S. Moorthi | threading, optimization, local dimension +!> 2019-07-24 | Li(Kate) Zhang | Merge and update ARAH Lu's work from NGAC into FV3-Chem +!> 2019-10-30 | Bo Cui | Remove "GOTO" statement +!> 2020-03-25 | Jesse Meng | Remove grib1 +!> 2020-05-20 | Jesse Meng | CALRH unification with NAM scheme +!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS Module +!> 2021-02-08 | Anning Cheng | read aod550, aod550_du/su/ss/oc/bc directly from fv3gfs and output to grib2 by setting rdaod +!> 2021-04-01 | Jesse Meng | Computation on defined points only +!> +!> @author Russ Treadon W/NP2 @date 1993-08-30 SUBROUTINE CLDRAD ! @@ -107,18 +78,19 @@ SUBROUTINE CLDRAD HBOT, HBOTD, HBOTS, HTOP, HTOPD, HTOPS, FIS, PBLH, & PBOT, PBOTL, PBOTM, PBOTH, CNVCFR, PTOP, PTOPL, & PTOPM, PTOPH, TTOPL, TTOPM, TTOPH, PBLCFR, CLDWORK, & - ASWIN, AUVBIN, AUVBINC, ASWIN, ASWOUT,ALWOUT, ASWTOA,& + ASWIN, AUVBIN, AUVBINC, ASWOUT,ALWOUT, ASWTOA,& RLWTOA, CZMEAN, CZEN, RSWIN, ALWIN, ALWTOA, RLWIN, & SIGT4, RSWOUT, RADOT, RSWINC, ASWINC, ASWOUTC, & ASWTOAC, ALWOUTC, ASWTOAC, AVISBEAMSWIN, & - AVISDIFFSWIN, ASWINTOA, ASWINC, ASWTOAC, AIRBEAMSWIN,& + AVISDIFFSWIN, ASWINTOA, ASWTOAC, AIRBEAMSWIN,& AIRDIFFSWIN, DUSMASS, DUSMASS25, DUCMASS, DUCMASS25, & ALWINC, ALWTOAC, SWDDNI, SWDDIF, SWDNBC, SWDDNIC, & SWDDIFC, SWUPBC, LWDNBC, LWUPBC, SWUPT, & TAOD5502D, AERSSA2D, AERASY2D, MEAN_FRP, LWP, IWP, & AVGCPRATE, & DUSTCB,SSCB,BCCB,OCCB,SULFCB,DUSTPM,SSPM,aod550, & - du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550 + du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550, & + PWAT use masks, only: LMH, HTM use params_mod, only: TFRZ, D00, H99999, QCLDMIN, SMALL, D608, H1, ROG, & GI, RD, QCONV, ABSCOEFI, ABSCOEF, STBOL, PQ0, A2, & @@ -255,6 +227,7 @@ SUBROUTINE CLDRAD data INDX_EXT / 610, 611, 612, 613, 614 / data INDX_SCA / 651, 652, 653, 654, 655 / logical, parameter :: debugprint = .false. + logical :: Model_Pwat ! ! !************************************************************************* @@ -422,12 +395,29 @@ SUBROUTINE CLDRAD IF (IGET(080) > 0) THEN ! dong GRID1 = spval + Model_Pwat = .false. + DO J=JSTA,JEND + DO I=ISTA,IEND + IF(ABS(PWAT(I,J)-SPVAL)>SMALL) THEN + Model_Pwat = .true. + exit + ENDIF + END DO + END DO + IF (Model_Pwat) THEN + DO J=JSTA,JEND + DO I=ISTA,IEND + GRID1(I,J) = PWAT(I,J) + END DO + END DO + ELSE CALL CALPW(GRID1(ista:iend,jsta:jend),1) DO J=JSTA,JEND DO I=ISTA,IEND IF(FIS(I,J) >= SPVAL) GRID1(I,J)=spval END DO END DO + ENDIF CALL BOUND(GRID1,D00,H99999) if(grib == "grib2" )then cfld = cfld + 1 @@ -5642,9 +5632,9 @@ SUBROUTINE CLDRAD END subroutine cb_cover(cbcov) -! Calculate CB coverage by using fuzzy logic -! Evaluate membership of val in a fuzzy set fuzzy. -! Assume f is in x-log scale +!> Calculate CB coverage by using fuzzy logic +!> Evaluate membership of val in a fuzzy set fuzzy. +!> Assume f is in x-log scale use ctlblk_mod, only: SPVAL,JSTA,JEND,IM,ISTA,IEND implicit none real, intent(inout) :: cbcov(ISTA:IEND,JSTA:JEND) diff --git a/sorc/ncep_post.fd/CMakeLists.txt b/sorc/ncep_post.fd/CMakeLists.txt index 3fab5c995..bce8c8361 100644 --- a/sorc/ncep_post.fd/CMakeLists.txt +++ b/sorc/ncep_post.fd/CMakeLists.txt @@ -148,8 +148,6 @@ list(APPEND EXE_SRC GFSPOSTSIG.F INITPOST.F INITPOST_GFS_NEMS_MPIIO.f - INITPOST_GFS_NETCDF.f - INITPOST_GFS_NETCDF_PARA.f INITPOST_NEMS.f INITPOST_NETCDF.f WRFPOST.f @@ -227,7 +225,7 @@ if(BUILD_POSTEXEC) target_link_libraries(${EXENAME} PRIVATE wrf_io::wrf_io) endif() - install(TARGETS ${EXENAME} RUNTIME DESTINATION bin) + install(TARGETS ${EXENAME} RUNTIME DESTINATION ${exec_dir}) endif() install(DIRECTORY ${module_dir} DESTINATION ${CMAKE_INSTALL_PREFIX}) @@ -235,6 +233,6 @@ install(DIRECTORY ${module_dir} DESTINATION ${CMAKE_INSTALL_PREFIX}) install( TARGETS ${LIBNAME} EXPORT ${PROJECT_NAME}Exports - RUNTIME DESTINATION bin + RUNTIME DESTINATION ${exec_dir} LIBRARY DESTINATION lib ARCHIVE DESTINATION lib) diff --git a/sorc/ncep_post.fd/COLLECT.f b/sorc/ncep_post.fd/COLLECT.f index bcc8fab57..fc1a56f8f 100644 --- a/sorc/ncep_post.fd/COLLECT.f +++ b/sorc/ncep_post.fd/COLLECT.f @@ -1,35 +1,17 @@ !> @file -! -!> SUBPROGRAM: COLLECT GATHERS FROM ALL MPI TASKS -!! PRGRMMR: TUCCILLO ORG: IBM -!! -!! ABSTRACT: -!! GATHER "A" FROM ALL MPI TASKS ONTO TASK 0 -!! -!! PROGRAM HISTORY LOG: -!! 00-01-06 TUCCILLO - ORIGINAL -!! -!! USAGE: CALL COLLECT(A) -!! INPUT ARGUMENT LIST: -!! A - ARRAY BEING GATHERED -!! -!! OUTPUT ARGUMENT LIST: -!! A - GATHERED ARRAY - ONLY VALID ON TASK 0 -!! -!! OUTPUT FILES: -!! STDOUT - RUN TIME STANDARD OUT. -!! -!! SUBPROGRAMS CALLED: -!! MPI_GATHERV -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK.comm -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : IBM RS/6000 SP -!! +!> @brief Subroutine that collect gathers from all MPI tasks. +!> +!> @param[in] A Array being gathered. +!> @param[out] A gathered array - only valid on task 0. +!> +!> Gather "A" from all MPI tasks onto task 0. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2000-01-06 | Jim Tuccillo | Initial +!> +!> @author Jim Tuccillo IBM @date 2000-01-06 SUBROUTINE COLLECT (A, B) diff --git a/sorc/ncep_post.fd/COLLECT_LOC.f b/sorc/ncep_post.fd/COLLECT_LOC.f index 0d8ce1ff7..1fd6ea850 100644 --- a/sorc/ncep_post.fd/COLLECT_LOC.f +++ b/sorc/ncep_post.fd/COLLECT_LOC.f @@ -1,35 +1,17 @@ !> @file -! -!> SUBPROGRAM: COLLECT GATHERS FROM ALL MPI TASKS -!! PRGRMMR: TUCCILLO ORG: IBM -!! -!! ABSTRACT: -!! GATHER "A" FROM ALL MPI TASKS ONTO TASK 0 -!! -!! PROGRAM HISTORY LOG: -!! 00-01-06 TUCCILLO - ORIGINAL -!! -!! USAGE: CALL COLLECT(A) -!! INPUT ARGUMENT LIST: -!! A - ARRAY BEING GATHERED -!! -!! OUTPUT ARGUMENT LIST: -!! A - GATHERED ARRAY - ONLY VALID ON TASK 0 -!! -!! OUTPUT FILES: -!! STDOUT - RUN TIME STANDARD OUT. -!! -!! SUBPROGRAMS CALLED: -!! MPI_GATHERV -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK.comm -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : IBM RS/6000 SP -!! +!> @brief Subroutine that collect gathers from all MPI tasks. +!> +!> @param[in] A Array being gathered. +!> @param[out] A gathered array - only valid on task 0. +!> +!> Gather "A" from all MPI tasks onto task 0. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2000-01-06 | Jim Tuccillo | Initial +!> +!> @author Jim Tuccillo IBM @date 2000-01-06 SUBROUTINE COLLECT_LOC ( A, B ) diff --git a/sorc/ncep_post.fd/DEALLOCATE.f b/sorc/ncep_post.fd/DEALLOCATE.f index ecefcfbb4..ada0ddf80 100644 --- a/sorc/ncep_post.fd/DEALLOCATE.f +++ b/sorc/ncep_post.fd/DEALLOCATE.f @@ -1,35 +1,16 @@ !> @file -! -!> SUBPROGRAM: MPI_FIRST SET UP MESSGAE PASSING INFO -!! PRGRMMR: TUCCILLO ORG: IBM -!! -!! ABSTRACT: -!! SETS UP MESSAGE PASSING INFO -!! -!! PROGRAM HISTORY LOG: -!! 00-01-06 TUCCILLO - ORIGINAL -!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-06-19 MIKE BALDWIN - WRF VERSION -!! -!! USAGE: CALL MPI_FIRST -!! INPUT ARGUMENT LIST: -!! -!! OUTPUT ARGUMENT LIST: -!! -!! OUTPUT FILES: -!! STDOUT - RUN TIME STANDARD OUT. -!! -!! SUBPROGRAMS CALLED: -!! PARA_RANGE -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK.comm -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : IBM RS/6000 SP -!! +!> @brief MPI_FIRST set up message passing info. +!> +!> This routine sets up message passing info. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2000-01-06 | Jim Tuccillo | Initial +!> 2001-10-25 | H Chuang | Modified to process hybrid model output +!> 2002-06-19 | Mike Baldwin | WRF version +!> +!> @author Jim Tuccillo IBM @date 2000-01-06 SUBROUTINE DE_ALLOCATE ! @@ -387,6 +368,7 @@ SUBROUTINE DE_ALLOCATE deallocate(tedir) deallocate(twa) deallocate(fdnsst) + deallocate(pwat) ! GSD deallocate(rainc_bucket) deallocate(rainc_bucket1) diff --git a/sorc/ncep_post.fd/DEWPOINT.f b/sorc/ncep_post.fd/DEWPOINT.f index 3d6d2b20e..1b962871d 100644 --- a/sorc/ncep_post.fd/DEWPOINT.f +++ b/sorc/ncep_post.fd/DEWPOINT.f @@ -1,51 +1,46 @@ !> @file -! -!> SUBPROGRAM: DEWPOINT COMPUTES DEWPOINTS FROM VAPOR PRESSURE -!! PRGMMR: J TUCCILLO ORG: W/NP2 DATE: 90-05-19 -!! -!! ABSTRACT: COMPUTES THE DEWPOINTS FOR THE N VALUES -!! OF VAPOR PRESSURE IN ARRAY VP. -!! THE FORMULA: -!! -!! VP = 0.611 * (X**A) * EXP( (A+B)*(1-X) ) -!! -!! IS USED TO GET DEWPOINT TEMPERATURE T, WHERE -!! -!! X = T3/T, T3=TRIPLE PT TEMPERATURE, -!! VP=VAPOR PRESSURE IN CBS, 0.611=VP AT T3, -!! A=(SPEC. HT. OF WATER-CSUBP OF VAPOR)/GAS CONST OF VAPOR -!! AND -!! B=LATENT HEAT AT T3/(GAS CONST OF VAPOR TIMES T3). -!! -!! ON THE FIRST CALL, A TABLE TDP IS CONSTRUCTED GIVING -!! DEWPOINT AS A FUNCTION OF VAPOR PRESSURE. -!! -!! VALUES OF VP LESS THAN THE FIRST TABLE ENTRY -!! (RVP1 IN THE CODE) WILL BE GIVEN DEWPOINTS FOR -!! THAT BEGINNING VALUE. SIMILARLY , VP VALUES THAT -!! EXCEED THE MAXIMUM TABLE VALUE (RVP2 IN THE CODE) -!! WILL BE ASSIGNED DEWPOINTS FOR THAT MAXIMUM VALUE. -!! -!! THE VALUES 0.02 AND 8.0 FOR RVP1 AND RVP2 YIELD -!! DEWPOINTS OF 233.6K AND 314.7K,RESPECTIVELY. -!! -!! PROGRAM HISTORY LOG: -!! - 90-05-19 J TUCCILLO -!! - 93-05-12 R TREADON - EXPANDED TABLE SIZE AND RESET -!! RANGE OF PRESSURES COVERED BY -!! TABLE. -!! - 98-06-12 T BLACK - CONVERSION FROM 1-D TO 2-D -!! - 00-01-04 JIM TUCCILLO - MPI VERSION -!! - 21-07-26 W Meng - Restrict computation from undefined grids -!! - 21-10-15 JESSE MENG - 2D DECOMPOSITION -!! -!! USAGE: CALL DEWPOINT( VP, TD) -!! INPUT ARGUMENT LIST: -!! VP - ARRAY OF N VAPOR PRESSURES(CENTIBARS) -!! -!! OUTPUT ARGUMENT LIST: -!! TD - DEWPOINT IN DEGREES ABSOLUTE -!! +!> @brief Subroutine that computes dewpoints from vapor pressure. +!> +!> This routine is to computes the dewpoints for the N values +!> of vapor pressure in array VP. +!> The forumla: +!> +!> VP = 0.611 * (X**A) * EXP( (A+B)*(1-X) ) +!> +!> is used to get dewpoint temperature T, where +!> +!> X = T3/T, T3=Triple PT temperature, +!> VP=Vapor pressure in CBS, 0.611=VP at T3, +!> A=(Spec. HT. of WATER-CSUBP of vapor)/gas const of vapor +!> and +!> B=Latent heat at T3/(gas const of vapor times T3). +!> +!> on the first call, a table TDP is constructed giving +!> dewpoint as a function of vapor pressure. +!> +!> Values of VP less than the first table entry +!> (RVP1 in the code) will be given dewpoints for +!> that beginning valus. Similarly, VP vaules that +!> exceed the maximum table value (RVP2 in the code) +!> will be assigned dewpoints for that maximum value. +!> +!> The values 0.02 and 8.0 for RVP1 and RVP2 yield +!> dewpoints of 233.6K and 314.7K,respectively. +!> +!> @param[in] VP Array of N vapor pressures(centibars). +!> @param[out] TD Dewpoint in degrees absolute. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1990-05-19 | Jim Tuccillo | Initial +!> 1993-05-12 | R Treadon | Expanded table size and reset range of pressures covered by table. +!> 1998-06-12 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2021-07-26 | W Meng | Restrict computation from undefined grids +!> 2021-10-31 | J Meng | 2D Decomposition +!> +!> @author Jim Tuccillo W/NP2 @date 1990-05-19 SUBROUTINE DEWPOINT( VP, TD) use ctlblk_mod, only: jsta, jend, im, spval, ista, iend diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f deleted file mode 100644 index b61732212..000000000 --- a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f +++ /dev/null @@ -1,2761 +0,0 @@ -!> @file -! . . . -!> SUBPROGRAM: INITPOST_NETCDF INITIALIZE POST FOR RUN -!! PRGRMMR: Hui-Ya Chuang DATE: 2016-03-04 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF GFS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 2017-08-11 H Chuang start from INITPOST_GFS_NEMS_MPIIO.f -!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INITPOST_NETCDF -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_GFS_NETCDF(ncid3d) - - - use netcdf - use vrbls4d, only: dust, SALT, SUSO, SOOT, WASO, PP25, PP10 - use vrbls3d, only: t, q, uh, vh, pmid, pint, alpint, dpres, zint, zmid, o3, & - qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, & - tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, & - o3vdiff, o3prod, o3tndy, mwpv, unknown, vdiffzacce, zgdrag,cnvctummixing, & - vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, & - cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp, & - wh, qqg, ref_10cm - use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, & - cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, & - tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, radot, sigt4, & - cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, & - islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, & - bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, & - rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, & - snopcx, sfcux, sfcvx, sfcuxi, sfcvxi, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, & - smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, & - uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, & - ptoph, pboth, pblcfr, ttoph, runoff, maxtshltr, mintshltr, maxrhshltr, & - minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, & - cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa,rel_vort_maxhy1, & - maxqshltr, minqshltr, acond, sr, u10h, v10h,refd_max, w_up_max, w_dn_max, & - up_heli_max,up_heli_min,up_heli_max03,up_heli_min03,rel_vort_max01,u10max, v10max, & - avgedir,avgecan,avgetrans,avgesnow,avgprec_cont,avgcprate_cont,rel_vort_max, & - avisbeamswin,avisdiffswin,airbeamswin,airdiffswin,refdm10c_max,wspd10max, & - alwoutc,alwtoac,aswoutc,aswtoac,alwinc,aswinc,avgpotevp,snoavg, & - ti,aod550,du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550 - use soil, only: sldpth, sh2o, smc, stc - use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice - use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, & - eps => con_eps, epsm1 => con_epsm1 - use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa,pi - use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, & - ttblq, rdpq, rdtheq, stheq, the0q, the0 - use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, & - ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, & - jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,& - ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, & - jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, & - nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER,rdaod - use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, & - dxval, dyval, truelat2, truelat1, psmapf, cenlat,lonstartv, lonlastv, cenlonv, & - latstartv, latlastv, cenlatv,latstart_r,latlast_r,lonstart_r,lonlast_r - use upp_physics, only: fpvsnew -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! type(nemsio_gfile) :: nfile,ffile,rfile - integer,parameter :: nvar2d=48 -! character(nemsio_charkind) :: name2d(nvar2d) - integer :: nvar3d, numDims -! character(nemsio_charkind), allocatable :: name3din(:), name3dout(:) -! character(nemsio_charkind) :: varname,levtype -! -! INCLUDE/SET PARAMETERS. -! - INCLUDE "mpif.h" - -! integer,parameter:: MAXPTS=1000000 ! max im*jm points -! -! real,parameter:: con_g =9.80665e+0! gravity -! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O -! real,parameter:: con_rd =2.8705e+2 ! gas constant air -! real,parameter:: con_fvirt =con_rv/con_rd-1. -! real,parameter:: con_eps =con_rd/con_rv -! real,parameter:: con_epsm1 =con_rd/con_rv-1 -! -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - - real, parameter :: gravi = 1.0/grav - character(len=20) :: VarName, VcoordName - integer :: Status, fldsize, fldst, recn, recn_vvel - character startdate*19,SysDepInfo*80,cgar*1 - character startdate2(19)*4 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL -! logical, parameter :: debugprint = .true., zerout = .false. - logical, parameter :: debugprint = .false., zerout = .false. - logical :: convert_rad_to_deg=.false. - CHARACTER*32 varcharval -! CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC - CHARACTER*4 RESTHR - CHARACTER FNAME*255,ENVAR*50 - INTEGER IDATE(8),JDATE(8),JPDS(200),JGDS(200),KPDS(200),KGDS(200) -! LOGICAL*1 LB(IM,JM) -! -! INCLUDE COMMON BLOCKS. -! -! DECLARE VARIABLES. -! -! REAL fhour -! integer nfhour ! forecast hour from nems io file - integer fhzero !bucket - real dtp !physics time step - REAL RINC(5) - -! REAL FI(IM,JM,2) - REAL DUMMY(IM,JM) - -!jw - integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, & - I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, & - nframed2,iunitd3d,ierr,idum,iret,nrec,idrt - integer ncid3d,ncid2d,varid,nhcas - real TSTART,TLMH,TSPH,ES,FACT,soilayert,soilayerb,zhour,dum, & - tvll,pmll,tv, tx1, tx2 - - character*20,allocatable :: recname(:) - integer, allocatable :: reclev(:), kmsk(:,:) - real, allocatable :: glat1d(:), glon1d(:), qstl(:) - real, allocatable :: wrk1(:,:), wrk2(:,:) - real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), & - qs2d(:,:), cw2d(:,:), cfr2d(:,:) - real(kind=4),allocatable :: vcoord4(:,:,:) - real, dimension(lm+1) :: ak5, bk5 - real*8, allocatable :: pm2d(:,:), pi2d(:,:) - real, allocatable :: tmp(:) - real :: buf(im,jsta_2l:jend_2u) - real :: buf3d(im,jsta_2l:jend_2u,lm) - -! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & -! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) - - real LAT - integer isa, jsa, latghf, jtem, idvc, idsl, nvcoord, ip1, nn, npass - - integer, parameter :: npass2=5, npass3=30 - real, parameter :: third=1.0/3.0 - INTEGER, DIMENSION(2) :: ij4min, ij4max - REAL :: omgmin, omgmax - real, allocatable :: d2d(:,:), u2d(:,:), v2d(:,:), omga2d(:,:) - REAL, ALLOCATABLE :: ps2d(:,:),psx2d(:,:),psy2d(:,:) - real, allocatable :: div3d(:,:,:) - real(kind=4),allocatable :: vcrd(:,:) - real :: dum_const - -!*********************************************************************** -! START INIT HERE. -! - WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NETCDF' - WRITE(6,*)'me=',me, & - 'jsta_2l=',jsta_2l,'jend_2u=', & - jend_2u,'im=',im -! - isa = im / 2 - jsa = (jsta+jend) / 2 - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - buf(i,j) = spval - enddo - enddo - - Status=nf90_get_att(ncid3d,nf90_global,'ak',ak5) - if(Status/=0)then - print*,'ak not found; assigning missing value' - ak5=spval - else - if(me==0)print*,'ak5= ',ak5 - end if - Status=nf90_get_att(ncid3d,nf90_global,'idrt',idrt) - if(Status/=0)then - print*,'idrt not in netcdf file,reading grid' - Status=nf90_get_att(ncid3d,nf90_global,'grid',varcharval) - if(Status/=0)then - print*,'idrt and grid not in netcdf file, set default to latlon' - idrt=0 - MAPTYPE=0 - else - if(trim(varcharval)=='rotated_latlon')then - MAPTYPE=207 - idrt=207 - Status=nf90_get_att(ncid3d,nf90_global,'cen_lon',dum_const) - if(Status/=0)then - print*,'cen_lon not found; assigning missing value' - cenlon=spval - else - if(dum_const<0.)then - cenlon=nint((dum_const+360.)*gdsdegr) - else - cenlon=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'cen_lat',dum_const) - if(Status/=0)then - print*,'cen_lat not found; assigning missing value' - cenlat=spval - else - cenlat=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const) - if(Status/=0)then - print*,'lonstart_r not found; assigning missing value' - lonstart_r=spval - else - if(dum_const<0.)then - lonstart_r=nint((dum_const+360.)*gdsdegr) - else - lonstart_r=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const) - if(Status/=0)then - print*,'latstart_r not found; assigning missing value' - latstart_r=spval - else - latstart_r=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const) - if(Status/=0)then - print*,'lonlast_r not found; assigning missing value' - lonlast_r=spval - else - if(dum_const<0.)then - lonlast_r=nint((dum_const+360.)*gdsdegr) - else - lonlast_r=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const) - if(Status/=0)then - print*,'latlast_r not found; assigning missing value' - latlast_r=spval - else - latlast_r=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const) - if(Status/=0)then - print*,'dlmd not found; assigning missing value' - dxval=spval - else - dxval=dum_const*gdsdegr - end if - Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const) - if(Status/=0)then - print*,'dphd not found; assigning missing value' - dyval=spval - else - dyval=dum_const*gdsdegr - end if - - print*,'lonstart,latstart,cenlon,cenlat,dyval,dxval', & - lonstart,latstart,cenlon,cenlat,dyval,dxval - -! Jili Dong add support for regular lat lon (2019/03/22) start - else if(trim(varcharval)=='latlon')then - MAPTYPE=0 - idrt=0 - - Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const) - if(Status/=0)then - print*,'lonstart not found; assigning missing value' - lonstart=spval - else - if(dum_const<0.)then - lonstart=nint((dum_const+360.)*gdsdegr) - else - lonstart=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const) - if(Status/=0)then - print*,'latstart not found; assigning missing value' - latstart=spval - else - latstart=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const) - if(Status/=0)then - print*,'lonlast not found; assigning missing value' - lonlast=spval - else - if(dum_const<0.)then - lonlast=nint((dum_const+360.)*gdsdegr) - else - lonlast=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const) - if(Status/=0)then - print*,'latlast not found; assigning missing value' - latlast=spval - else - latlast=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const) - if(Status/=0)then - print*,'dlmd not found; assigning missing value' - dxval=spval - else - dxval=dum_const*gdsdegr - end if - Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const) - if(Status/=0)then - print*,'dphd not found; assigning missing value' - dyval=spval - else - dyval=dum_const*gdsdegr - end if - - print*,'lonstart,latstart,dyval,dxval', & - lonstart,lonlast,latstart,latlast,dyval,dxval - -! Jili Dong add support for regular lat lon (2019/03/22) end - - else if(trim(varcharval)=='gaussian')then - MAPTYPE=4 - idrt=4 - else ! setting default maptype - MAPTYPE=0 - idrt=0 - end if - end if !end reading grid - end if !end reading idrt - if(me==0)print*,'idrt MAPTYPE= ',idrt,MAPTYPE -! STEP 1. READ MODEL OUTPUT FILE -! -! -!*** -! -! LMH and LMV always = LM for sigma-type vert coord - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i = 1, im - LMV(i,j) = lm - LMH(i,j) = lm - end do - end do - -! HTM VTM all 1 for sigma-type vert coord - -!$omp parallel do private(i,j,l) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - HTM (i,j,l) = 1.0 - VTM (i,j,l) = 1.0 - end do - end do - end do - - Status=nf90_get_att(ncid3d,nf90_global,'nhcas',nhcas) - if(Status/=0)then - print*,'nhcas not in netcdf file, set default to nonhydro' - nhcas=0 - end if - if(me==0)print*,'nhcas= ',nhcas - if (nhcas == 0 ) then !non-hydrostatic case - nrec=15 - allocate (recname(nrec)) - recname=[character(len=20) :: 'ugrd','vgrd','spfh','tmp','o3mr', & - 'presnh','dzdt', 'clwmr','dpres', & - 'delz','icmr','rwmr', & - 'snmr','grle','cld_amt'] - else - nrec=8 - allocate (recname(nrec)) - recname=[character(len=20) :: 'ugrd','vgrd','tmp','spfh','o3mr', & - 'hypres', 'clwmr','dpres'] - endif - -! write(0,*)'nrec=',nrec - !allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - allocate(glat1d(jm),glon1d(im)) - allocate(vcoord4(lm+1,3,2)) - -! hardwire idate for now -! idate=(/2017,08,07,00,0,0,0,0/) -! get cycle start time - Status=nf90_inq_varid(ncid3d,'time',varid) - if(Status/=0)then - print*,'time not in netcdf file, stopping' - STOP 1 - else - Status=nf90_get_att(ncid3d,varid,'units',varcharval) - if(Status/=0)then - print*,'time unit not available' - else - print*,'time unit read from netcdf file= ',varcharval -! assume use hours as unit -! idate_loc=index(varcharval,'since')+6 - read(varcharval,101)idate(1),idate(2),idate(3),idate(4),idate(5) - end if -! Status=nf90_inquire_dimension(ncid3d,varid,len=ntimes) -! allocate(fhours(ntimes)) -! status = nf90_inq_varid(ncid3d,varid,fhours) -! Status=nf90_get_var(ncid3d,varid,nfhour,start=(/1/), & -! count=(/1/)) -! if(Status/=0)then -! print*,'forecast hour not in netcdf file, stopping' -! STOP 1 -! end if - end if - 101 format(T13,i4,1x,i2,1x,i2,1x,i2,1x,i2) - print*,'idate= ',idate(1:5) -! get longitude - Status=nf90_inq_varid(ncid3d,'grid_xt',varid) - Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) - if(debugprint)print*,'number of dim for gdlon ',numDims - if(numDims==1)then - Status=nf90_get_var(ncid3d,varid,glon1d) - do j=jsta,jend - do i=1,im - gdlon(i,j) = real(glon1d(i),kind=4) - end do - end do - lonstart = nint(glon1d(1)*gdsdegr) - lonlast = nint(glon1d(im)*gdsdegr) - dxval = nint(abs(glon1d(1)-glon1d(2))*gdsdegr) - else if(numDims==2)then - Status=nf90_get_var(ncid3d,varid,dummy) - if(maxval(abs(dummy))<2.0*pi)convert_rad_to_deg=.true. - if(convert_rad_to_deg)then - do j=jsta,jend - do i=1,im - gdlon(i,j) = real(dummy(i,j),kind=4)*180./pi - end do - end do - else - do j=jsta,jend - do i=1,im - gdlon(i,j) = real(dummy(i,j),kind=4) - end do - end do - end if - if(convert_rad_to_deg)then - lonstart = nint(dummy(1,1)*gdsdegr)*180./pi - lonlast = nint(dummy(im,jm)*gdsdegr)*180./pi - dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr)*180./pi - else - lonstart = nint(dummy(1,1)*gdsdegr) - lonlast = nint(dummy(im,jm)*gdsdegr) - dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr) - end if - -! Jili Dong add support for regular lat lon (2019/03/22) start - if (MAPTYPE == 0) then - if(lonstart<0.)then - lonstart=lonstart+360.*gdsdegr - end if - if(lonlast<0.)then - lonlast=lonlast+360.*gdsdegr - end if - end if -! Jili Dong add support for regular lat lon (2019/03/22) end - - end if - print*,'lonstart,lonlast,dxval ',lonstart,lonlast,dxval -! get latitude - Status=nf90_inq_varid(ncid3d,'grid_yt',varid) - Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) - if(debugprint)print*,'number of dim for gdlat ',numDims - if(numDims==1)then - Status=nf90_get_var(ncid3d,varid,glat1d) - do j=jsta,jend - do i=1,im - gdlat(i,j) = real(glat1d(j),kind=4) - end do - end do - latstart = nint(glat1d(1)*gdsdegr) - latlast = nint(glat1d(jm)*gdsdegr) - dyval = nint(abs(glat1d(1)-glat1d(2))*gdsdegr) - else if(numDims==2)then - Status=nf90_get_var(ncid3d,varid,dummy) - if(maxval(abs(dummy))1.0e5)print*,'bad dpres ',i,j,dpres(i,j,l) -!make sure delz is positive -! if(dpres(i,j,l)/=spval .and. t(i,j,l)/=spval .and. & -! q(i,j,l)/=spval .and. buf3d(i,j,l)/=spval)then -! pmid(i,j,l)=rgas*dpres(i,j,l)* & -! t(i,j,l)*(q(i,j,l)*fv+1.0)/grav/abs(buf3d(i,j,l)) -! else -! pmid(i,j,l)=spval -! end if -! dong add missing value - if (wh(i,j,l) < spval) then - omga(i,j,l)=(-1.)*wh(i,j,l)*dpres(i,j,l)/abs(buf3d(i,j,l)) - else - omga(i,j,l) = spval - end if -! if(t(i,j,l)>1000.)print*,'bad T ',t(i,j,l) - enddo - enddo - enddo - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(11) & - ,lm,qqi(1,jsta_2l,1)) - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(12) & - ,lm,qqr(1,jsta_2l,1)) - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(13) & - ,lm,qqs(1,jsta_2l,1)) - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(14) & - ,lm,qqg(1,jsta_2l,1)) - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(15) & - ,lm,cfr(1,jsta_2l,1)) -! calculate CWM from FV3 output - do l=1,lm - do j=jsta,jend - do i=1,im - cwm(i,j,l)=qqg(i,j,l)+qqs(i,j,l)+qqr(i,j,l)+qqi(i,j,l)+qqw(i,j,l) - enddo - enddo - if(debugprint)print*,'sample l,t,q,u,v,w,= ',isa,jsa,l & - ,t(isa,jsa,l),q(isa,jsa,l),uh(isa,jsa,l),vh(isa,jsa,l) & - ,wh(isa,jsa,l) - if(debugprint)print*,'sample l cwm for FV3',l, & - cwm(isa,jsa,l) - end do -! max hourly updraft velocity -! VarName='upvvelmax' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,w_up_max) -! if(debugprint)print*,'sample ',VarName,' = ',w_up_max(isa,jsa) - -! max hourly downdraft velocity -! VarName='dnvvelmax' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,w_dn_max) -! if(debugprint)print*,'sample ',VarName,' = ',w_dn_max(isa,jsa) -! max hourly updraft helicity -! VarName='uhmax25' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_max) -! if(debugprint)print*,'sample ',VarName,' = ',up_heli_max(isa,jsa) -! min hourly updraft helicity -! VarName='uhmin25' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_min) -! if(debugprint)print*,'sample ',VarName,' = ',up_heli_min(isa,jsa) -! max hourly 0-3km updraft helicity -! VarName='uhmax03' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_max03) -! if(debugprint)print*,'sample ',VarName,' = ',up_heli_max03(isa,jsa) -! min hourly 0-3km updraft helicity -! VarName='uhmin03' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_min03) -! if(debugprint)print*,'sample ',VarName,' = ',up_heli_min03(isa,jsa) - -! max 0-1km relative vorticity max -! VarName='maxvort01' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_max01) -! if(debugprint)print*,'sample ',VarName,' = ',rel_vort_max01(isa,jsa) -! max 0-2km relative vorticity max -! VarName='maxvort02' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_max) -! if(debugprint)print*,'sample ',VarName,' =',rel_vort_max(isa,jsa) -! max hybrid lev 1 relative vorticity max -! VarName='maxvorthy1' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_maxhy1) -! if(debugprint)print*,'sample ',VarName,' =',rel_vort_maxhy1(isa,jsa) -! surface pressure - VarName='pressfc' - call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,pint(1,jsta_2l,lp1)) - do j=jsta,jend - do i=1,im -! if(pint(i,j,lp1)>1.0E6 .or. pint(1,jsta_2l,lp1)<50000.) & -! print*,'bad psfc ',i,j,pint(i,j,lp1) - end do - end do - if(debugprint)print*,'sample ',VarName,' =',pint(isa,jsa,lp1) - - pt = ak5(1) - - do j=jsta,jend - do i=1,im - pint(i,j,1)= pt - end do - end do - - do l=2,lp1 - do j=jsta,jend - do i=1,im - pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) - enddo - enddo -! if (me == 0) print*,'sample model pint,pmid' ,ii,jj,l & -! ,pint(ii,jj,l),pmid(ii,jj,l) - end do - -!compute pmid from averaged two layer pint - do l=lm,1,-1 - do j=jsta,jend - do i=1,im - pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) - enddo - enddo - enddo - -! do l=lm,1,-1 -! do j=jsta,jend -! do i=1,im -! if(pint(i,j,l+1)/=spval .and. dpres(i,j,l)/=spval)then -! pint(i,j,l)=pint(i,j,l+1)-dpres(i,j,l) -! else -! pint(i,j,l)=spval -! end if -! end do -! end do -! print*,'sample pint= ',isa,jsa,l,pint(isa,jsa,l) -! end do - -! surface height from FV3 -! dong set missing value for zint -! zint=spval - VarName='hgtsfc' - call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,zint(1,jsta_2l,lp1)) - if(debugprint)print*,'sample ',VarName,' =',zint(isa,jsa,lp1) - do j=jsta,jend - do i=1,im - if (zint(i,j,lp1) /= spval) then - fis(i,j) = zint(i,j,lp1) * grav - else - fis(i,j) = spval - endif - enddo - enddo - - do l=lm,1,-1 - do j=jsta,jend - do i=1,im - if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then -!make sure delz is positive - zint(i,j,l)=zint(i,j,l+1)+abs(buf3d(i,j,l)) -! if(zint(i,j,l)>1.0E6)print*,'bad H ',i,j,l,zint(i,j,l) - else - zint(i,j,l)=spval - end if - end do - end do - print*,'sample zint= ',isa,jsa,l,zint(isa,jsa,l) - end do - - do l=lp1,1,-1 - do j=jsta,jend - do i=1,im - alpint(i,j,l)=log(pint(i,j,l)) - end do - end do - end do - - do l=lm,1,-1 - do j=jsta,jend - do i=1,im - if(zint(i,j,l+1)/=spval .and. zint(i,j,l)/=spval & - .and. pmid(i,j,l)/=spval)then - zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & - (log(pmid(i,j,l))-alpint(i,j,l+1))/ & - (alpint(i,j,l)-alpint(i,j,l+1)) - if(zmid(i,j,l)>1.0E6)print*,'bad Hmid ',i,j,l,zmid(i,j,l) - else - zmid(i,j,l)=spval - endif - end do - end do - end do - - - pt = ak5(1) - -! else -! do l=2,lm -!!$omp parallel do private(i,j) -! do j=jsta,jend -! do i=1,im -! pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) -! enddo -! enddo -! if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l) -! end do -! endif -! - - deallocate (vcoord4) -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -! - -! done with 3d file, close it for now - Status=nf90_close(ncid3d) - deallocate(recname) - -! open flux file - Status = nf90_open(trim(fileNameFlux),NF90_NOWRITE, ncid2d) - - if ( Status /= 0 ) then - print*,'error opening ',fileNameFlux, ' Status = ', Status - print*,'skip reading of flux file' - endif - -! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD - VarName='IVEGSRC' - Status=nf90_get_att(ncid2d,nf90_global,'IVEGSRC',IVEGSRC) - if (Status /= 0) then - print*,VarName,' not found-Assigned 1 for IGBP as default' - IVEGSRC=1 - end if - if (me == 0) print*,'IVEGSRC= ',IVEGSRC - -! set novegtype based on vegetation classification - if(ivegsrc==2)then - novegtype=13 - else if(ivegsrc==1)then - novegtype=20 - else if(ivegsrc==0)then - novegtype=24 - end if - if (me == 0) print*,'novegtype= ',novegtype - - Status=nf90_get_att(ncid2d,nf90_global,'imp_physics',imp_physics) - if (Status /= 0) then - print*,VarName,' not found-Assigned 11 GFDL as default' - imp_physics=11 - end if - if (me == 0) print*,'MP_PHYSICS= ',imp_physics -! - Status=nf90_get_att(ncid2d,nf90_global,'fhzero',fhzero) - if (Status /= 0) then - print*,VarName,' not found-Assigned 3 hours as default' - fhzero=3 - end if - if (me == 0) print*,'fhzero= ',fhzero -! - Status=nf90_get_att(ncid2d,nf90_global,'dtp',dtp) - if (Status /= 0) then - print*,VarName,' not found-Assigned 90s as default' - dtp=90 - end if - if (me == 0) print*,'dtp= ',dtp -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95) then - CALL MICROINIT(imp_physics) - end if - -! Chuang: zhour is when GFS empties bucket last so using this -! to compute buket will result in changing bucket with forecast time. -! set default bucket for now - -! call nemsio_getheadvar(ffile,'zhour',zhour,iret=iret) -! if(iret == 0) then -! tprec = 1.0*ifhr-zhour -! tclod = tprec -! trdlw = tprec -! trdsw = tprec -! tsrfc = tprec -! tmaxmin = tprec -! td3d = tprec -! print*,'tprec from flux file header= ',tprec -! else -! print*,'Error reading accumulation bucket from flux file', & -! 'header - will try to read from env variable FHZER' -! CALL GETENV('FHZER',ENVAR) -! read(ENVAR, '(I2)')idum -! tprec = idum*1.0 -! tclod = tprec -! trdlw = tprec -! trdsw = tprec -! tsrfc = tprec -! tmaxmin = tprec -! td3d = tprec -! print*,'TPREC from FHZER= ',tprec -! end if - - - tprec = float(fhzero) - if(ifhr>240)tprec=12. - tclod = tprec - trdlw = tprec - trdsw = tprec - tsrfc = tprec - tmaxmin = tprec - td3d = tprec - print*,'tprec = ',tprec - - -! start reading 2d netcdf file -! surface pressure -! VarName='pressfc' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & -! ,pint(1,jsta_2l,lp1)) -! if(debugprint)print*,'sample ',VarName,' =',pint(isa,jsa,lp1) -! do l=lm,1,-1 -! do j=jsta,jend -! do i=1,im -! pint(i,j,l)=pint(i,j,l+1)-dpres(i,j,l) -! if(pint(i,j,l)>1.0E6)print*,'bad P ',i,j,l,pint(i,j,l) & -! ,pint(i,j,l+1),dpres(i,j,l) -! end do -! end do -! print*,'sample pint= ',isa,jsa,l,pint(isa,jsa,l) -! end do -! surface height from FV3 already multiplied by G -! VarName='orog' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,fis) -! if(debugprint)print*,'sample ',VarName,' =',fis(isa,jsa) -! do j=jsta,jend -! do i=1,im -! if (fis(i,j) /= spval) then -! zint(i,j,lp1) = fis(i,j) -! fis(i,j) = fis(i,j) * grav -! else -! zint(i,j,lp1) = spval -! fis(i,j) = spval -! endif -! enddo -! enddo - -! do l=lm,1,-1 -! do j=jsta,jend -! do i=1,im -! if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then -! zint(i,j,l)=zint(i,j,l+1)+buf3d(i,j,l) -! if(zint(i,j,l)>1.0E6)print*,'bad H ',i,j,l,zint(i,j,l) -! else -! zint(i,j,l)=spval -! end if -! end do -! end do -! print*,'sample zint= ',isa,jsa,l,zint(isa,jsa,l) -! end do - -! Per communication with Fanglin, P from model in not monotonic -! so compute P using ak and bk for now Sep. 2017 -! do l=lm,1,-1 -!!!$omp parallel do private(i,j) -! do j=jsta,jend -! do i=1,im -! pint(i,j,l) = ak5(lm+2-l) + bk5(lm+2-l)*pint(i,j,lp1) -! pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) ! for now - -! enddo -! enddo -! print*,'sample pint,pmid' & -! ,l,pint(isa,jsa,l),pmid(isa,jsa,l) -! enddo - -! allocate(wrk1(im,jsta:jend),wrk2(im,jsta:jend)) -! do j=jsta,jend -! do i=1,im -! pd(i,j) = spval ! GFS does not output PD -! pint(i,j,1) = PT -! alpint(i,j,lp1) = log(pint(i,j,lp1)) -! wrk1(i,j) = log(PMID(I,J,LM)) -! wrk2(i,j) = T(I,J,LM)*(Q(I,J,LM)*fv+1.0) -! FI(I,J,1) = FIS(I,J) & -! + wrk2(i,j)*rgas*(ALPINT(I,J,Lp1)-wrk1(i,j)) -! ZMID(I,J,LM) = FI(I,J,1) * gravi -! end do -! end do - -! SECOND, INTEGRATE HEIGHT HYDROSTATICLY, GFS integrate height on -! mid-layer - -! DO L=LM,2,-1 ! omit computing model top height -! ll = l - 1 -! do j = jsta, jend -! do i = 1, im -! alpint(i,j,l) = log(pint(i,j,l)) -! tvll = T(I,J,LL)*(Q(I,J,LL)*fv+1.0) -! pmll = log(PMID(I,J,LL)) - -! FI(I,J,2) = FI(I,J,1) + (0.5*rgas)*(wrk2(i,j)+tvll) & -! * (wrk1(i,j)-pmll) -! ZMID(I,J,LL) = FI(I,J,2) * gravi -! -! FACT = (ALPINT(I,J,L)-wrk1(i,j)) / (pmll-wrk1(i,j)) -! ZINT(I,J,L) = ZMID(I,J,L) +(ZMID(I,J,LL)-ZMID(I,J,L))*FACT -! FI(I,J,1) = FI(I,J,2) -! wrk1(i,J) = pmll -! wrk2(i,j) = tvll -! ENDDO -! ENDDO - -! print*,'L ZINT= ',l,zint(isa,jsa,l),ZMID(isa,jsa,l) -! ,'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)), & -! 'pmid(l-1)=',LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L), & -! 'zmid(l-1)=',ZMID(Ii,Jj,L-1) -! ENDDO -! deallocate(wrk1,wrk2) - -! do l=lp1,2,-1 -! do j=jsta,jend -! do i=1,im -! alpint(i,j,l)=log(pint(i,j,l)) -! end do -! end do -! end do - -! do l=lm,2,-1 -! do j=jsta,jend -! do i=1,im -! zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & -! (log(pmid(i,j,l))-alpint(i,j,l+1))/ & -! (alpint(i,j,l)-alpint(i,j,l+1)) -! if(zmid(i,j,l)>1.0E6)print*,'bad Hmid ',i,j,l,zmid(i,j,l) -! end do -! end do -! end do - -! VarName='refl_10cm' -! do l=1,lm -! call read_netcdf_3d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & -! ,lm,REF_10CM(1,jsta_2l,1)) -! if(debugprint)print*,'sample ',VarName,'isa,jsa,l =' & -! ,REF_10CM(isa,jsa,l),isa,jsa,l -! enddo -!Set REF_10CM as missning since gfs doesn't ouput it - do l=1,lm - do j=jsta,jend - do i=1,im - REF_10CM(i,j,l)=spval - enddo - enddo - enddo - - VarName='land' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sm) - if(debugprint)print*,'sample ',VarName,' =',sm(im/2,(jsta+jend)/2) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j) - enddo - enddo - -! sea ice mask - - VarName = 'icec' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sice) - if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa) - -! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea -! mask=0 -! GFS flux files have land points with non-zero sea ice, per Iredell, -! these -! points have sea ice changed to zero, i.e., trust land mask more than -! sea ice -! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0 - enddo - enddo - - -! PBL height using nemsio - VarName = 'hpbl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pblh) - if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa) - -! frictional velocity using nemsio - VarName='fricv' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ustar) -! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa) - -! roughness length using getgb - VarName='sfcr' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,z0) -! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa) - -! sfc exchange coeff - VarName='sfexc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,SFCEXC) - -! aerodynamic conductance - VarName='acond' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,acond) - if(debugprint)print*,'sample ',VarName,' = ',acond(isa,jsa) -! mid day avg albedo - VarName='albdo_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgalbedo) - if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) - do j=jsta,jend - do i=1,im - if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 - enddo - enddo - -! surface potential T using getgb - VarName='tmpsfc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ths) - -! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (ths(i,j) /= spval) then -! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) - ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa - endif - QS(i,j) = SPVAL ! GFS does not have surface specific humidity - twbs(i,j) = SPVAL ! GFS does not have inst sensible heat flux - qwbs(i,j) = SPVAL ! GFS does not have inst latent heat flux -!assign sst - if (sm(i,j) /= 0.0) then - sst(i,j) = ths(i,j) * (pint(i,j,lp1)/p1000)**capa - else - sst(i,j) = spval - endif - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa) - - -! GFS does not have time step and physics time step, make up ones since they -! are not really used anyway -! NPHS=1. -! DT=90. -! DTQ2 = DT * NPHS !MEB need to get physics DT - DTQ2 = DTP !MEB need to get physics DT - NPHS=1 - DT = DTQ2/NPHS !MEB need to get DT - TSPH = 3600./DT - -! convective precip in m per physics time step using getgb -! read 3 hour bucket - VarName='cpratb_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcprate) -! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa) - -! print*,'maxval CPRATE: ', maxval(CPRATE) - -! read continuous bucket - VarName='cprat_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcprate_cont) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcprate_cont(i,j) /= spval) avgcprate_cont(i,j) = & - avgcprate_cont(i,j) * (dtq2*0.001) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcprate_cont(isa,jsa) - -! print*,'maxval CPRATE: ', maxval(CPRATE) - -! precip rate in m per physics time step using getgb - VarName='prateb_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgprec) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if(avgprec(i,j) /= spval)avgprec(i,j)=avgprec(i,j)*(dtq2*0.001) - enddo - enddo - - if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa) - -! prec = avgprec !set avg cprate to inst one to derive other fields - - VarName='prate_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgprec_cont) -! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgprec_cont(i,j) /=spval)avgprec_cont(i,j)=avgprec_cont(i,j) & - * (dtq2*0.001) - enddo - enddo - - if(debugprint)print*,'sample ',VarName,' = ',avgprec_cont(isa,jsa) -! precip rate in m per physics time step - VarName='tprcp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,prec) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (prec(i,j) /= spval) prec(i,j)=prec(i,j)* (dtq2*0.001) & - * 1000. / dtp - enddo - enddo - -! convective precip rate in m per physics time step - VarName='cnvprcp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cprate) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cprate(i,j) /= spval) then - cprate(i,j) = max(0.,cprate(i,j)) * (dtq2*0.001) & - * 1000. / dtp - else - cprate(i,j) = 0. - endif - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',cprate(isa,jsa) - -! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f - -! max hourly 1-km agl reflectivity -! VarName='refdmax' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refd_max) -! if(debugprint)print*,'sample ',VarName,' = ',refd_max(isa,jsa) -! max hourly -10C reflectivity -! VarName='refdmax263k' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refdm10c_max) -! if(debugprint)print*,'sample ',VarName,' = ',refdm10c_max(isa,jsa) - -! max hourly u comp of 10m agl wind -! VarName='u10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,u10max) -! if(debugprint)print*,'sample ',VarName,' = ',u10max(isa,jsa) -! max hourly v comp of 10m agl wind -! VarName='v10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,v10max) -! if(debugprint)print*,'sample ',VarName,' = ',v10max(isa,jsa) -! max hourly 10m agl wind speed -! VarName='spd10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,wspd10max) -! if(debugprint)print*,'sample ',VarName,' = ',wspd10max(isa,jsa) - - -! 2m T using nemsio - VarName='tmp2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,tshltr) - if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) - -! inst snow water eqivalent using nemsio - VarName='weasd' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sno) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j)==0.) sno(i,j) = spval - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa) - -! ave snow cover - VarName='snowc_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,snoavg) -! snow cover is multipled by 100 in SURFCE before writing it out - do j=jsta,jend - do i=1,im - if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j)=spval - if(snoavg(i,j)/=spval)snoavg(i,j)=snoavg(i,j)/100. - end do - end do - -! snow depth in mm using nemsio - VarName='snod' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,si) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval - if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 - CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency - lspa(i,j) = spval ! GFS does not have similated precip - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - Q10(i,j) = SPVAL ! GFS does not have 10 m humidity - ALBASE(i,j) = SPVAL ! GFS does not have snow free albedo - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa) - -! 2m T using nemsio - VarName='tmp2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,tshltr) - if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) - -! GFS does not have 2m pres, estimate it, also convert t to theta - Do j=jsta,jend - Do i=1,im - PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample 2m T and P after scatter= ' -! + ,i,j,tshltr(i,j),pshltr(i,j) - end do - end do - -! 2m specific humidity using nemsio - VarName='spfh2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,qshltr) - if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa) - -! mid day avg albedo in fraction using nemsio -! VarName='albdosfc' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgalbedo) -!! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction -!!$omp parallel do private(i,j) -! do j=jsta,jend -! do i=1,im -! if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 -! enddo -! enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) - -! time averaged column cloud fractionusing nemsio - VarName='tcdc_aveclm' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgtcdc) -! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa) - -! GFS probably does not use zenith angle -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - Czen(i,j) = spval - CZMEAN(i,j) = SPVAL - enddo - enddo - -! maximum snow albedo in fraction using nemsio - VarName='snoalb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,mxsnal) -! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa) - -! GFS probably does not use sigt4, set it to sig*t^4 -!$omp parallel do private(i,j,tlmh) - Do j=jsta,jend - Do i=1,im - TLMH = T(I,J,LM) * T(I,J,LM) - Sigt4(i,j) = 5.67E-8 * TLMH * TLMH - End do - End do - -! TG is not used, skip it for now - -! GFS does not have inst cloud fraction for high, middle, and low cloud -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - cfrach(i,j) = spval - cfracl(i,j) = spval - cfracm(i,j) = spval - enddo - enddo - -! ave high cloud fraction using nemsio - VarName='tcdc_avehcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfrach) -! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa) - -! ave low cloud fraction using nemsio - VarName='tcdc_avelcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfracl) -! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa) - -! ave middle cloud fraction using nemsio - VarName='tcdc_avemcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfracm) -! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa) - -! inst convective cloud fraction using nemsio - VarName='tcdccnvcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cnvcfr) -! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa) - -! slope type using nemsio - VarName='sltyp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf) -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - islope(i,j) = nint(buf(i,j)) - else - islope(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa) - -! plant canopy sfc wtr in m - VarName='cnwat' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cmc) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001 - if (sm(i,j) /= 0.0) cmc(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - grnflx(i,j) = spval ! GFS does not have inst ground heat flux - enddo - enddo - -! frozen precip fraction using nemsio - VarName='cpofp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sr) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if(sr(i,j) /= spval) then -!set range within (0,1) - sr(i,j)=min(1.,max(0.,sr(i,j))) - endif - enddo - enddo - -! sea ice skin temperature - VarName='tisfc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ti) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sice(i,j) == spval .or. sice(i,j) == 0.) ti(i,j)=spval - enddo - enddo - -! vegetation fraction in fraction. using nemsio - VarName='veg' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,vegfrc) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (vegfrc(i,j) /= spval) then - vegfrc(i,j) = vegfrc(i,j) * 0.01 - else - vegfrc(i,j) = 0.0 - endif - enddo - enddo -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) vegfrc(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa) - -! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam - - SLDPTH(1) = 0.10 - SLDPTH(2) = 0.3 - SLDPTH(3) = 0.6 - SLDPTH(4) = 1.0 - -! liquid volumetric soil mpisture in fraction using nemsio - VarName='soill1' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,1)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1) - - VarName='soill2' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,2)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2) - - VarName='soill3' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,3)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3) - - VarName='soill4' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,4)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4) - -! volumetric soil moisture using nemsio - VarName='soilw1' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,1)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1) - - VarName='soilw2' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,2)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2) - - VarName='soilw3' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,3)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3) - - VarName='soilw4' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,4)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4) - -! soil temperature using nemsio - VarName='soilt1' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,1)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,1) = spval - !if (sm(i,j) /= 0.0) stc(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1) - - VarName='soilt2' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,2)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,2) = spval - !if (sm(i,j) /= 0.0) stc(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2) - - VarName='soilt3' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,3)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,3) = spval - !if (sm(i,j) /= 0.0) stc(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3) - - VarName='soilt4' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,4)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,4) = spval - !if (sm(i,j) /= 0.0) stc(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 - ncfrcv(i,j) = 1.0 - acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 - ncfrst(i,j) = 1.0 - bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF - rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave - enddo - enddo -! trdlw(i,j) = 6.0 - ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1 - -! time averaged incoming sfc longwave - VarName='dlwrf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwin) - -! inst incoming sfc longwave - VarName='dlwrf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rlwin) - -! time averaged outgoing sfc longwave - VarName='ulwrf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwout) -! inst outgoing sfc longwave - VarName='ulwrf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,radot) - -! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa) - -! time averaged outgoing model top longwave using gfsio - VarName='ulwrf_avetoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa) - -! GFS incoming sfc longwave has been averaged, set ARDLW to 1 - ardsw=1.0 -! trdsw=6.0 - -! time averaged incoming sfc shortwave - VarName='dswrf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswin) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa) - -! inst incoming sfc shortwave - VarName='dswrf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswin) - -! inst incoming clear sky sfc shortwave - VarName='csdlf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswinc) - -! time averaged incoming sfc uv-b using getgb - VarName='duvb_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,auvbin) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa) - -! time averaged incoming sfc clear sky uv-b using getgb - VarName='cduvb_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,auvbinc) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa) - -! time averaged outgoing sfc shortwave using gfsio - VarName='uswrf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswout) -! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa) - -! inst outgoing sfc shortwave using gfsio - VarName='uswrf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswout) - -! time averaged model top incoming shortwave - VarName='dswrf_avetoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswintoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswintoa(isa,jsa) - -! time averaged model top outgoing shortwave - VarName='uswrf_avetoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa) - -! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux -! has reversed sign convention using gfsio - VarName='shtfl_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcshx) -! where (sfcshx /= spval)sfcshx=-sfcshx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa) - -! inst surface sensible heat flux - VarName='shtfl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,twbs) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (twbs(i,j) /= spval) twbs(i,j) = -twbs(i,j) - enddo - enddo - -! GFS surface flux has been averaged, set ASRFC to 1 - asrfc=1.0 -! tsrfc=6.0 - -! time averaged surface latent heat flux, multiplied by -1 because wrf model flux -! has reversed sign vonvention using gfsio - VarName='lhtfl_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfclhx) -! where (sfclhx /= spval)sfclhx=-sfclhx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa) - -! inst surface latent heat flux - VarName='lhtfl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,qwbs) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (qwbs(i,j) /= spval) qwbs(i,j) = -qwbs(i,j) - enddo - enddo - - if(me==0)print*,'rdaod= ',rdaod -! inst aod550 optical depth - if(rdaod) then - VarName='aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aod550) - - VarName='du_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,du_aod550) - - VarName='ss_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ss_aod550) - - VarName='su_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,su_aod550) - - VarName='oc_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,oc_aod550) - - VarName='bc_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,bc_aod550) - end if - -! time averaged ground heat flux using nemsio - VarName='gflux_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,subshx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa) - -! inst ground heat flux using nemsio - VarName='gflux' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,grnflx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval - enddo - enddo - -! time averaged zonal momentum flux using gfsio - VarName='uflx_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcux) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa) - -! time averaged meridional momentum flux using nemsio - VarName='vflx_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcvx) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa) - -! dong read in inst surface flux -! inst zonal momentum flux using gfsio -! VarName='uflx' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcuxi) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcuxi(isa,jsa) - -! inst meridional momentum flux using nemsio -! VarName='vflx' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcvxi) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvxi(isa,jsa) - - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - sfcuvx(i,j) = spval ! GFS does not use total momentum flux - enddo - enddo - -! time averaged zonal gravity wave stress using nemsio - VarName='u-gwd_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,gtaux) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa) - -! time averaged meridional gravity wave stress using getgb - VarName='v-gwd_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,gtauy) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa) - -! time averaged accumulated potential evaporation - VarName='pevpr_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgpotevp) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa) - -! inst potential evaporation - VarName='pevpr' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,potevp) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval - enddo - enddo - - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im -! GFS does not have temperature tendency due to long wave radiation - rlwtt(i,j,l) = spval -! GFS does not have temperature tendency due to short wave radiation - rswtt(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from convection - tcucn(i,j,l) = spval - tcucns(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from grid scale - train(i,j,l) = spval - enddo - enddo - enddo - -! set avrain to 1 - avrain=1.0 - avcnvc=1.0 - theat=6.0 ! just in case GFS decides to output T tendency - -! 10 m u using nemsio - VarName='ugrd10m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,u10) - - do j=jsta,jend - do i=1,im - u10h(i,j)=u10(i,j) - end do - end do -! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa) - -! 10 m v using gfsio - VarName='vgrd10m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,v10) - - do j=jsta,jend - do i=1,im - v10h(i,j)=v10(i,j) - end do - end do -! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa) - -! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='vtype' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf) -! where (buf /= spval) -! ivgtyp=nint(buf) -! elsewhere -! ivgtyp=0 !need to feed reasonable value to crtm -! end where -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - ivgtyp(i,j) = nint(buf(i,j)) - else - ivgtyp(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa) - -! soil type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='sotyp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf) - VcoordName='sfc' - l=1 -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - isltyp(i,j) = nint(buf(i,j)) - else - isltyp(i,j) = 0 !need to feed reasonable value to crtm - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - smstav(i,j) = spval ! GFS does not have soil moisture availability -! smstot(i,j) = spval ! GFS does not have total soil moisture - sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation - acsnow(i,j) = spval ! GFS does not have averaged accumulated snow - acsnom(i,j) = spval ! GFS does not have snow melt -! sst(i,j) = spval ! GFS does not have sst???? - thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute - qz0(i,j) = spval ! GFS does not output humidity at roughness length - uz0(i,j) = spval ! GFS does not output u at roughness length - vz0(i,j) = spval ! GFS does not output humidity at roughness length - enddo - enddo - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - EL_PBL(i,j,l) = spval ! GFS does not have mixing length - exch_h(i,j,l) = spval ! GFS does not output exchange coefficient - enddo - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa) - -! retrieve inst convective cloud top, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index -! VarName='pres' -! VcoordName='convect-cld top' -! l=1 -! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa) - VarName='prescnvclt' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptop) - - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - htop(i,j) = spval - if(ptop(i,j) <= 0.0) ptop(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im - if(ptop(i,j) < spval)then - do l=1,lm - if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j) = l -! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', & -! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j) - exit - end if - end do - end if - end do - end do - -! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index - VarName='prescnvclb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbot) -! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - hbot(i,j) = spval - if(pbot(i,j) <= 0.0) pbot(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im -! if(.not.lb(i,j))print*,'false bitmask for pbot at ' -! + ,i,j,pbot(i,j) - if(pbot(i,j) < spval)then - do l=lm,1,-1 - if(pbot(i,j) >= pmid(i,j,l)) then - hbot(i,j) = l -! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', & -! pbot(i,j),pmid(i,j,l),hbot(i,j) - exit - end if - end do - end if - end do - end do - if(debugprint)print*,'sample hbot = ',hbot(isa,jsa) -! retrieve time averaged low cloud top pressure using nemsio - VarName='pres_avelct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptopl) -! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa) - -! retrieve time averaged low cloud bottom pressure using nemsio - VarName='pres_avelcb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbotl) -! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa) - -! retrieve time averaged low cloud top temperature using nemsio - VarName='tmp_avelct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttopl) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa) - -! retrieve time averaged middle cloud top pressure using nemsio - VarName='pres_avemct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa) - -! retrieve time averaged middle cloud bottom pressure using nemsio - VarName='pres_avemcb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbotm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa) - -! retrieve time averaged middle cloud top temperature using nemsio - VarName='tmp_avemct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa) - -! retrieve time averaged high cloud top pressure using nemsio ********* - VarName='pres_avehct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa) - -! retrieve time averaged high cloud bottom pressure using nemsio - VarName='pres_avehcb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pboth) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa) - -! retrieve time averaged high cloud top temperature using nemsio - VarName='tmp_avehct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa) - -! retrieve boundary layer cloud cover using nemsio - VarName='tcdc_avebndcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pblcfr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa) -! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01 - enddo - enddo - -! retrieve cloud work function - VarName='cwork_aveclm' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cldwork) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa) - -! accumulated total (base+surface) runoff - VarName='watr_acc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,runoff) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) runoff(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa) - -! retrieve shelter max temperature using nemsio - VarName='tmax_max2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxtshltr) - -! retrieve shelter min temperature using nemsio - VarName='tmin_min2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,mintshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & -! 1,mintshltr(im/2,(jsta+jend)/2) - -! retrieve shelter max RH -! VarName='rh02max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxrhshltr) - -! retrieve shelter min temperature using nemsio -! VarName='rh02min' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,minrhshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & -! 1,mintshltr(im/2,(jsta+jend)/2) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - MAXRHSHLTR(i,j) = SPVAL - MINRHSHLTR(i,j) = SPVAL - enddo - enddo - -! retrieve ice thickness using nemsio - VarName='icetk' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,dzice) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa) - -! retrieve wilting point using nemsio - VarName='wilt' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smcwlt) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smcwlt(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa) - -! retrieve sunshine duration using nemsio - VarName='sunsd_acc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,suntime) - -! retrieve field capacity using nemsio - VarName='fldcp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,fieldcapa) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) fieldcapa(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa) - -! retrieve time averaged surface visible beam downward solar flux - VarName='vbdsf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avisbeamswin) - VcoordName='sfc' - l=1 - -! retrieve time averaged surface visible diffuse downward solar flux - VarName='vddsf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avisdiffswin) - -! retrieve time averaged surface near IR beam downward solar flux - VarName='nbdsf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,airbeamswin) - -! retrieve time averaged surface near IR diffuse downward solar flux - VarName='nddsf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,airdiffswin) - -! retrieve time averaged surface clear sky outgoing LW - VarName='csulf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwoutc) - -! retrieve time averaged TOA clear sky outgoing LW - VarName='csulftoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwtoac) - -! retrieve time averaged surface clear sky outgoing SW - VarName='csusf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswoutc) - -! retrieve time averaged TOA clear sky outgoing LW - VarName='csusftoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswtoac) - -! retrieve time averaged surface clear sky incoming LW - VarName='csdlf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwinc) - -! retrieve time averaged surface clear sky incoming SW - VarName='csdsf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswinc) - -! retrieve shelter max specific humidity using nemsio - VarName='spfhmax_max2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxqshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', -! 1,maxqshltr(isa,jsa) - -! retrieve shelter min temperature using nemsio - VarName='spfhmin_min2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,minqshltr) - -! retrieve storm runoff using nemsio - VarName='ssrun_acc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,SSROFF) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) ssroff(i,j) = spval - enddo - enddo - -! retrieve direct soil evaporation - VarName='evbs_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgedir) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) avgedir(i,j) = spval - enddo - enddo - -! retrieve CANOPY WATER EVAP - VarName='evcw_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgecan) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) avgecan(i,j) = spval - enddo - enddo - -! retrieve PLANT TRANSPIRATION - VarName='trans_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgetrans) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) avgetrans(i,j) = spval - enddo - enddo - -! retrieve snow sublimation - VarName='sbsno_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgesnow) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval - enddo - enddo - -! retrive total soil moisture - VarName='soilm' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smstot) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smstot(i,j) = spval - enddo - enddo - -! retrieve snow phase change heat flux - VarName='snohf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,snopcx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) snopcx(i,j) = spval - enddo - enddo - -! GFS does not have deep convective cloud top and bottom fields - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - HTOPD(i,j) = SPVAL - HBOTD(i,j) = SPVAL - HTOPS(i,j) = SPVAL - HBOTS(i,j) = SPVAL - CUPPT(i,j) = SPVAL - enddo - enddo - -! done with flux file, close it for now - Status=nf90_close(ncid2d) -! deallocate(tmp,recname,reclevtyp,reclev) - -! pos east -! call collect_loc(gdlat,dummy) -! if(me == 0)then -! latstart = nint(dummy(1,1)*gdsdegr) -! latlast = nint(dummy(im,jm)*gdsdegr) -! print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,& -! 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1) -! end if -! call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) -! call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) -! write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me -! call collect_loc(gdlon,dummy) -! if(me == 0)then -! lonstart = nint(dummy(1,1)*gdsdegr) -! lonlast = nint(dummy(im,jm)*gdsdegr) -! end if -! call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) -! call mpi_bcast(lonlast, 1,MPI_INTEGER,0,mpi_comm_comp,irtn) - -! write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast -! - -! generate look up table for lifted parcel calculations - - THL = 210. - PLQ = 70000. - pt_TBL = 10000. ! this is for 100 hPa added by Moorthi - - CALL TABLE(PTBL,TTBL,PT_TBL, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - -! -! - IF(ME == 0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -!$omp parallel do private(l) - DO L = 1,LSM - ALSL(L) = LOG(SPL(L)) - END DO -! -!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - if(me == 0)then - print*,'writing out igds' - igdout = 110 -! open(igdout,file='griddef.out',form='unformatted' -! + ,status='unknown') - if(maptype == 1)THEN ! Lambert conformal - WRITE(igdout)3 - WRITE(6,*)'igd(1)=',3 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ELSE IF(MAPTYPE == 2)THEN !Polar stereographic - WRITE(igdout)5 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 !Assume projection at +-90 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ! Note: The calculation of the map scale factor at the standard - ! lat/lon and the PSMAPF - ! Get map factor at 60 degrees (N or S) for PS projection, which will - ! be needed to correctly define the DX and DY values in the GRIB GDS - if (TRUELAT1 < 0.) THEN - LAT = -60. - else - LAT = 60. - end if - - CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF) - - ELSE IF(MAPTYPE == 3) THEN !Mercator - WRITE(igdout)1 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)latlast - WRITE(igdout)lonlast - WRITE(igdout)TRUELAT1 - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)255 - ELSE IF(MAPTYPE == 0 .OR. MAPTYPE == 203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - END IF - end if -! -! - - RETURN - END - diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f deleted file mode 100644 index 888a26f31..000000000 --- a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f +++ /dev/null @@ -1,2691 +0,0 @@ -!> @file -! . . . -!> SUBPROGRAM: INITPOST_GFS_NETCDF_PARA INITIALIZE POST FOR RUN -!! PRGRMMR: Wen Meng DATE: 2020-02-04 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF GFS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 2020-02-04 W Meng start from INITPOST_GFS_NETCDF.f -!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) -!! 2021-10-26 J Meng 2D DECOMPOSITION -!! -!! USAGE: CALL INITPOST_GFS_NETCDF_PARA -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) - - - use netcdf - use vrbls4d, only: dust, SALT, SUSO, SOOT, WASO, PP25, PP10 - use vrbls3d, only: t, q, uh, vh, pmid, pint, alpint, dpres, zint, zmid, o3, & - qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, & - tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, & - o3vdiff, o3prod, o3tndy, mwpv, unknown, vdiffzacce, zgdrag,cnvctummixing, & - vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, & - cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp, & - wh, qqg, ref_10cm - use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, & - cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, & - tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, landfrac, radot, sigt4, & - cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, & - islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, & - bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, & - rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, & - snopcx, sfcux, sfcvx, sfcuxi, sfcvxi, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, & - smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, & - uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, & - ptoph, pboth, pblcfr, ttoph, runoff, tecan, tetran, tedir, twa, maxtshltr, & - mintshltr, maxrhshltr, fdnsst, & - minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, & - cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa,rel_vort_maxhy1, & - maxqshltr, minqshltr, acond, sr, u10h, v10h,refd_max, w_up_max, w_dn_max, & - up_heli_max,up_heli_min,up_heli_max03,up_heli_min03,rel_vort_max01,u10max, v10max, & - avgedir,avgecan,paha,pahi,avgetrans,avgesnow,avgprec_cont,avgcprate_cont,rel_vort_max, & - avisbeamswin,avisdiffswin,airbeamswin,airdiffswin,refdm10c_max,wspd10max, & - alwoutc,alwtoac,aswoutc,aswtoac,alwinc,aswinc,avgpotevp,snoavg, & - ti,aod550,du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550 - use soil, only: sldpth, sh2o, smc, stc - use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice - use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, & - eps => con_eps, epsm1 => con_epsm1 - use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa,pi - use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, & - ttblq, rdpq, rdtheq, stheq, the0q, the0 - use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, & - ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, & - jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,& - ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, & - jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, & - nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER,rdaod, & - 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 - - use upp_physics, only: fpvsnew -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! type(nemsio_gfile) :: nfile,ffile,rfile - integer,parameter :: nvar2d=48 -! character(nemsio_charkind) :: name2d(nvar2d) - integer :: nvar3d, numDims -! character(nemsio_charkind), allocatable :: name3din(:), name3dout(:) -! character(nemsio_charkind) :: varname,levtype -! -! INCLUDE/SET PARAMETERS. -! - INCLUDE "mpif.h" - -! integer,parameter:: MAXPTS=1000000 ! max im*jm points -! -! real,parameter:: con_g =9.80665e+0! gravity -! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O -! real,parameter:: con_rd =2.8705e+2 ! gas constant air -! real,parameter:: con_fvirt =con_rv/con_rd-1. -! real,parameter:: con_eps =con_rd/con_rv -! real,parameter:: con_epsm1 =con_rd/con_rv-1 -! -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - - real, parameter :: gravi = 1.0/grav - character(len=20) :: VarName, VcoordName - integer :: Status, fldsize, fldst, recn, recn_vvel - character startdate*19,SysDepInfo*80,cgar*1 - character startdate2(19)*4 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL -! logical, parameter :: debugprint = .true., zerout = .false. - logical, parameter :: debugprint = .false., zerout = .false. - logical :: convert_rad_to_deg=.false. - CHARACTER*32 varcharval -! CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC - CHARACTER*4 RESTHR - CHARACTER FNAME*255,ENVAR*50 - INTEGER IDATE(8),JDATE(8),JPDS(200),JGDS(200),KPDS(200),KGDS(200) -! LOGICAL*1 LB(IM,JM) -! -! INCLUDE COMMON BLOCKS. -! -! DECLARE VARIABLES. -! -! REAL fhour - integer nfhour ! forecast hour from nems io file - integer fhzero !bucket - real dtp !physics time step - REAL RINC(5) - - REAL DUMMY(IM,JM) -!jw - integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, & - I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, & - nframed2,iunitd3d,ierr,idum,iret,nrec,idrt - integer ncid3d,ncid2d,varid,nhcas - real TSTART,TLMH,TSPH,ES,FACT,soilayert,soilayerb,zhour,dum, & - tvll,pmll,tv, tx1, tx2 - - character*20,allocatable :: recname(:) - integer, allocatable :: reclev(:), kmsk(:,:) - real, allocatable :: glat1d(:), glon1d(:), qstl(:) - real, allocatable :: wrk1(:,:), wrk2(:,:) - real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), & - qs2d(:,:), cw2d(:,:), cfr2d(:,:) - real(kind=4),allocatable :: vcoord4(:,:,:) - real, dimension(lm+1) :: ak5, bk5 - real*8, allocatable :: pm2d(:,:), pi2d(:,:) - real, allocatable :: tmp(:) - real :: buf(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 LAT - integer isa, jsa, latghf, jtem, idvc, idsl, nvcoord, ip1, nn, npass - - integer, parameter :: npass2=5, npass3=30 - real, parameter :: third=1.0/3.0 - INTEGER, DIMENSION(2) :: ij4min, ij4max - REAL :: omgmin, omgmax - real, allocatable :: d2d(:,:), u2d(:,:), v2d(:,:), omga2d(:,:) - REAL, ALLOCATABLE :: ps2d(:,:),psx2d(:,:),psy2d(:,:) - real, allocatable :: div3d(:,:,:) - real(kind=4),allocatable :: vcrd(:,:) - real :: dum_const - -!*********************************************************************** -! START INIT HERE. -! - WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NETCDF_PARA' - WRITE(6,*)'me=',me, & - 'jsta_2l=',jsta_2l,'jend_2u=', & - jend_2u,'im=',im, & - 'ista_2l=',ista_2l,'iend_2u=',iend_2u, & - 'ista=',ista,'iend=',iend, & - 'iend_m=',iend_m -! - isa = (ista+iend) / 2 - jsa = (jsta+jend) / 2 - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=ista_2l, iend_2u - buf(i,j) = spval - enddo - enddo - - Status=nf90_get_att(ncid3d,nf90_global,'ak',ak5) - if(Status/=0)then - print*,'ak not found; assigning missing value' - ak5=spval - else - if(me==0)print*,'ak5= ',ak5 - end if - Status=nf90_get_att(ncid3d,nf90_global,'idrt',idrt) - if(Status/=0)then - print*,'idrt not in netcdf file,reading grid' - Status=nf90_get_att(ncid3d,nf90_global,'grid',varcharval) - if(Status/=0)then - print*,'idrt and grid not in netcdf file, set default to latlon' - idrt=0 - MAPTYPE=0 - else - if(trim(varcharval)=='rotated_latlon')then - MAPTYPE=207 - idrt=207 - Status=nf90_get_att(ncid3d,nf90_global,'cen_lon',dum_const) - if(Status/=0)then - print*,'cen_lon not found; assigning missing value' - cenlon=spval - else - if(dum_const<0.)then - cenlon=nint((dum_const+360.)*gdsdegr) - else - cenlon=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'cen_lat',dum_const) - if(Status/=0)then - print*,'cen_lat not found; assigning missing value' - cenlat=spval - else - cenlat=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const) - if(Status/=0)then - print*,'lonstart_r not found; assigning missing value' - lonstart_r=spval - else - if(dum_const<0.)then - lonstart_r=nint((dum_const+360.)*gdsdegr) - else - lonstart_r=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const) - if(Status/=0)then - print*,'latstart_r not found; assigning missing value' - latstart_r=spval - else - latstart_r=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const) - if(Status/=0)then - print*,'lonlast_r not found; assigning missing value' - lonlast_r=spval - else - if(dum_const<0.)then - lonlast_r=nint((dum_const+360.)*gdsdegr) - else - lonlast_r=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const) - if(Status/=0)then - print*,'latlast_r not found; assigning missing value' - latlast_r=spval - else - latlast_r=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const) - if(Status/=0)then - print*,'dlmd not found; assigning missing value' - dxval=spval - else - dxval=dum_const*gdsdegr - end if - Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const) - if(Status/=0)then - print*,'dphd not found; assigning missing value' - dyval=spval - else - dyval=dum_const*gdsdegr - end if - - print*,'lonstart,latstart,cenlon,cenlat,dyval,dxval', & - lonstart,latstart,cenlon,cenlat,dyval,dxval - -! Jili Dong add support for regular lat lon (2019/03/22) start - else if(trim(varcharval)=='latlon')then - MAPTYPE=0 - idrt=0 - - Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const) - if(Status/=0)then - print*,'lonstart not found; assigning missing value' - lonstart=spval - else - if(dum_const<0.)then - lonstart=nint((dum_const+360.)*gdsdegr) - else - lonstart=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const) - if(Status/=0)then - print*,'latstart not found; assigning missing value' - latstart=spval - else - latstart=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const) - if(Status/=0)then - print*,'lonlast not found; assigning missing value' - lonlast=spval - else - if(dum_const<0.)then - lonlast=nint((dum_const+360.)*gdsdegr) - else - lonlast=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const) - if(Status/=0)then - print*,'latlast not found; assigning missing value' - latlast=spval - else - latlast=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const) - if(Status/=0)then - print*,'dlmd not found; assigning missing value' - dxval=spval - else - dxval=dum_const*gdsdegr - end if - Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const) - if(Status/=0)then - print*,'dphd not found; assigning missing value' - dyval=spval - else - dyval=dum_const*gdsdegr - end if - - print*,'lonstart,latstart,dyval,dxval', & - lonstart,lonlast,latstart,latlast,dyval,dxval - -! Jili Dong add support for regular lat lon (2019/03/22) end - - else if(trim(varcharval)=='gaussian')then - MAPTYPE=4 - idrt=4 - else ! setting default maptype - MAPTYPE=0 - idrt=0 - end if - end if !end reading grid - end if !end reading idrt - if(me==0)print*,'idrt MAPTYPE= ',idrt,MAPTYPE -! STEP 1. READ MODEL OUTPUT FILE -! -! -!*** -! -! LMH and LMV always = LM for sigma-type vert coord - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i = ista_2l, iend_2u - LMV(i,j) = lm - LMH(i,j) = lm - end do - end do - -! HTM VTM all 1 for sigma-type vert coord - -!$omp parallel do private(i,j,l) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = ista_2l, iend_2u - HTM (i,j,l) = 1.0 - VTM (i,j,l) = 1.0 - end do - end do - end do - - Status=nf90_get_att(ncid3d,nf90_global,'nhcas',nhcas) - if(Status/=0)then - print*,'nhcas not in netcdf file, set default to nonhydro' - nhcas=0 - end if - if(me==0)print*,'nhcas= ',nhcas - if (nhcas == 0 ) then !non-hydrostatic case - nrec=15 - allocate (recname(nrec)) - recname=[character(len=20) :: 'ugrd','vgrd','spfh','tmp','o3mr', & - 'presnh','dzdt', 'clwmr','dpres', & - 'delz','icmr','rwmr', & - 'snmr','grle','cld_amt'] - else - nrec=8 - allocate (recname(nrec)) - recname=[character(len=20) :: 'ugrd','vgrd','tmp','spfh','o3mr', & - 'hypres', 'clwmr','dpres'] - endif - -! write(0,*)'nrec=',nrec - !allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - allocate(glat1d(jm),glon1d(im)) - allocate(vcoord4(lm+1,3,2)) - -! hardwire idate for now -! idate=(/2017,08,07,00,0,0,0,0/) -! get cycle start time - Status=nf90_inq_varid(ncid3d,'time',varid) - if(Status/=0)then - print*,'time not in netcdf file, stopping' - STOP 1 - else - Status=nf90_get_att(ncid3d,varid,'units',varcharval) - if(Status/=0)then - print*,'time unit not available' - else - print*,'time unit read from netcdf file= ',varcharval -! assume use hours as unit -! idate_loc=index(varcharval,'since')+6 - read(varcharval,101)idate(1),idate(2),idate(3),idate(4),idate(5) - end if -! Status=nf90_inquire_dimension(ncid3d,varid,len=ntimes) -! allocate(fhours(ntimes)) -! status = nf90_inq_varid(ncid3d,varid,fhours) -! Status=nf90_get_var(ncid3d,varid,nfhour,start=(/1/), & -! count=(/1/)) -! if(Status/=0)then -! print*,'forecast hour not in netcdf file, stopping' -! STOP 1 -! end if - end if - 101 format(T13,i4,1x,i2,1x,i2,1x,i2,1x,i2) - print*,'idate= ',idate(1:5) -! get longitude - Status=nf90_inq_varid(ncid3d,'grid_xt',varid) - Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) - if(debugprint)print*,'number of dim for gdlon ',numDims - if(numDims==1)then - Status=nf90_get_var(ncid3d,varid,glon1d) - do j=jsta,jend - do i=ista,iend - gdlon(i,j) = real(glon1d(i),kind=4) - end do - end do - lonstart = nint(glon1d(1)*gdsdegr) - lonlast = nint(glon1d(im)*gdsdegr) - dxval = nint(abs(glon1d(1)-glon1d(2))*gdsdegr) - else if(numDims==2)then - Status=nf90_get_var(ncid3d,varid,dummy) - if(maxval(abs(dummy))<2.0*pi)convert_rad_to_deg=.true. - if(convert_rad_to_deg)then - do j=jsta,jend - do i=ista,iend - gdlon(i,j) = real(dummy(i,j),kind=4)*180./pi - end do - end do - else - do j=jsta,jend - do i=ista,iend - gdlon(i,j) = real(dummy(i,j),kind=4) - end do - end do - end if - if(convert_rad_to_deg)then - lonstart = nint(dummy(1,1)*gdsdegr)*180./pi - lonlast = nint(dummy(im,jm)*gdsdegr)*180./pi - dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr)*180./pi - else - lonstart = nint(dummy(1,1)*gdsdegr) - lonlast = nint(dummy(im,jm)*gdsdegr) - dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr) - end if - -! Jili Dong add support for regular lat lon (2019/03/22) start - if (MAPTYPE == 0) then - if(lonstart<0.)then - lonstart=lonstart+360.*gdsdegr - end if - if(lonlast<0.)then - lonlast=lonlast+360.*gdsdegr - end if - end if -! Jili Dong add support for regular lat lon (2019/03/22) end - - end if - print*,'lonstart,lonlast,dxval,me = ',lonstart,lonlast,dxval,me -! get latitude - Status=nf90_inq_varid(ncid3d,'grid_yt',varid) - Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) - if(debugprint)print*,'number of dim for gdlat ',numDims - if(numDims==1)then - Status=nf90_get_var(ncid3d,varid,glat1d) - do j=jsta,jend - do i=ista,iend - gdlat(i,j) = real(glat1d(j),kind=4) - end do - end do - latstart = nint(glat1d(1)*gdsdegr) - latlast = nint(glat1d(jm)*gdsdegr) - dyval = nint(abs(glat1d(1)-glat1d(2))*gdsdegr) - else if(numDims==2)then - Status=nf90_get_var(ncid3d,varid,dummy) - if(maxval(abs(dummy))1000.)print*,'bad T ',t(i,j,l) - enddo - enddo - enddo - call read_netcdf_3d_para(ncid3d,im,jm,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,recname(11),qqi(ista_2l,jsta_2l,1),lm) - call read_netcdf_3d_para(ncid3d,im,jm,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,recname(12),qqr(ista_2l,jsta_2l,1),lm) - call read_netcdf_3d_para(ncid3d,im,jm,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,recname(13),qqs(ista_2l,jsta_2l,1),lm) - call read_netcdf_3d_para(ncid3d,im,jm,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,recname(14),qqg(ista_2l,jsta_2l,1),lm) - call read_netcdf_3d_para(ncid3d,im,jm,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,recname(15),cfr(ista_2l,jsta_2l,1),lm) - -! calculate CWM from FV3 output - do l=1,lm - do j=jsta,jend - do i=ista,iend - cwm(i,j,l)=qqg(i,j,l)+qqs(i,j,l)+qqr(i,j,l)+qqi(i,j,l)+qqw(i,j,l) - enddo - enddo - if(debugprint)print*,'sample l,t,q,u,v,w,= ',isa,jsa,l & - ,t(isa,jsa,l),q(isa,jsa,l),uh(isa,jsa,l),vh(isa,jsa,l) & - ,wh(isa,jsa,l) - if(debugprint)print*,'sample l cwm for FV3',l, & - cwm(isa,jsa,l) - end do - -! surface pressure - VarName='pressfc' - call read_netcdf_2d_para(ncid3d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pint(ista_2l,jsta_2l,lp1)) - do j=jsta,jend - do i=ista,iend -! if(pint(i,j,lp1)>1.0E6 .or. pint(1,jsta_2l,lp1)<50000.) & -! print*,'bad psfc ',i,j,pint(i,j,lp1) - end do - end do - if(debugprint)print*,'sample ',VarName,' =',pint(isa,jsa,lp1) - - pt = ak5(1) - - do j=jsta,jend - do i=ista,iend - pint(i,j,1)= pt - end do - end do - - do l=2,lp1 - do j=jsta,jend - do i=ista,iend - pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) - enddo - enddo -! if (me == 0) print*,'sample model pint,pmid' ,ii,jj,l & -! ,pint(ii,jj,l),pmid(ii,jj,l) - end do - -!compute pmid from averaged two layer pint - do l=lm,1,-1 - do j=jsta,jend - do i=ista,iend - pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) - enddo - enddo - enddo - -! surface height from FV3 -! dong set missing value for zint -! zint=spval - VarName='hgtsfc' - call read_netcdf_2d_para(ncid3d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,zint(ista_2l,jsta_2l,lp1)) - if(debugprint)print*,'sample ',VarName,' =',zint(isa,jsa,lp1) - do j=jsta,jend - do i=ista,iend - if (zint(i,j,lp1) /= spval) then - fis(i,j) = zint(i,j,lp1) * grav - else - fis(i,j) = spval - endif - enddo - enddo - - do l=lm,1,-1 - do j=jsta,jend - do i=ista,iend - if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then -!make sure delz is positive - zint(i,j,l)=zint(i,j,l+1)+abs(buf3d(i,j,l)) -! if(zint(i,j,l)>1.0E6)print*,'bad H ',i,j,l,zint(i,j,l) - else - zint(i,j,l)=spval - end if - end do - end do - print*,'sample zint= ',isa,jsa,l,zint(isa,jsa,l) - end do - - do l=lp1,1,-1 - do j=jsta,jend - do i=ista,iend - alpint(i,j,l)=log(pint(i,j,l)) - end do - end do - end do - - do l=lm,1,-1 - do j=jsta,jend - do i=ista,iend - if(zint(i,j,l+1)/=spval .and. zint(i,j,l)/=spval & - .and. pmid(i,j,l)/=spval)then - zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & - (log(pmid(i,j,l))-alpint(i,j,l+1))/ & - (alpint(i,j,l)-alpint(i,j,l+1)) - if(zmid(i,j,l)>1.0E6)print*,'bad Hmid ',i,j,l,zmid(i,j,l) - else - zmid(i,j,l)=spval - endif - end do - end do - end do - - - pt = ak5(1) - -! - - deallocate (vcoord4) -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -! - -! done with 3d file, close it for now - Status=nf90_close(ncid3d) - deallocate(recname) - -! open flux file - Status = nf90_open(trim(fileNameFlux),ior(nf90_nowrite, nf90_mpiio), & - ncid2d,comm=mpi_comm_world,info=mpi_info_null) - if ( Status /= 0 ) then - print*,'error opening ',fileNameFlux, ' Status = ', Status - print*,'skip reading of flux file' - endif - -! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD - VarName='IVEGSRC' - Status=nf90_get_att(ncid2d,nf90_global,'IVEGSRC',IVEGSRC) - if (Status /= 0) then - print*,VarName,' not found-Assigned 1 for IGBP as default' - IVEGSRC=1 - end if - if (me == 0) print*,'IVEGSRC= ',IVEGSRC - -! set novegtype based on vegetation classification - if(ivegsrc==2)then - novegtype=13 - else if(ivegsrc==1)then - novegtype=20 - else if(ivegsrc==0)then - novegtype=24 - end if - if (me == 0) print*,'novegtype= ',novegtype - - Status=nf90_get_att(ncid2d,nf90_global,'imp_physics',imp_physics) - if (Status /= 0) then - print*,VarName,' not found-Assigned 11 GFDL as default' - imp_physics=11 - end if - if (me == 0) print*,'MP_PHYSICS= ',imp_physics -! - Status=nf90_get_att(ncid2d,nf90_global,'fhzero',fhzero) - if (Status /= 0) then - print*,VarName,' not found-Assigned 3 hours as default' - fhzero=3 - end if - if (me == 0) print*,'fhzero= ',fhzero -! - Status=nf90_get_att(ncid2d,nf90_global,'dtp',dtp) - if (Status /= 0) then - print*,VarName,' not found-Assigned 90s as default' - dtp=90 - end if - if (me == 0) print*,'dtp= ',dtp -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95) then - CALL MICROINIT(imp_physics) - end if - - tprec = float(fhzero) - if(ifhr>240)tprec=12. - tclod = tprec - trdlw = tprec - trdsw = tprec - tsrfc = tprec - tmaxmin = tprec - td3d = tprec - print*,'tprec = ',tprec - - -!Set REF_10CM as missning since gfs doesn't ouput it - do l=1,lm - do j=jsta,jend - do i=ista,iend - REF_10CM(i,j,l)=spval - enddo - enddo - enddo - - VarName='land' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sm) - if(debugprint)print*,'sample ',VarName,' =',sm((ista+iend)/2,(jsta+jend)/2) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j) - enddo - enddo - -! sea ice mask - - VarName = 'icec' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sice) - if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa) - -! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea -! mask=0 -! GFS flux files have land points with non-zero sea ice, per Iredell, -! these -! points have sea ice changed to zero, i.e., trust land mask more than -! sea ice -! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0 - enddo - enddo - - -! PBL height using nemsio - VarName = 'hpbl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pblh) - if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa) - -! frictional velocity using nemsio - VarName='fricv' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ustar) -! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa) - -! roughness length using getgb - VarName='sfcr' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,z0) -! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa) - -! sfc exchange coeff - VarName='sfexc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,SFCEXC) - -! aerodynamic conductance - VarName='acond' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,acond) - if(debugprint)print*,'sample ',VarName,' = ',acond(isa,jsa) - -! mid day avg albedo - VarName='albdo_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgalbedo) - if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) - do j=jsta,jend - do i=ista,iend - if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 - enddo - enddo - -! surface potential T using getgb - VarName='tmpsfc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ths) - -! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (ths(i,j) /= spval) then -! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) - ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa - endif - QS(i,j) = SPVAL ! GFS does not have surface specific humidity - twbs(i,j) = SPVAL ! GFS does not have inst sensible heat flux - qwbs(i,j) = SPVAL ! GFS does not have inst latent heat flux -!assign sst - if (sm(i,j) /= 0.0) then - sst(i,j) = ths(i,j) * (pint(i,j,lp1)/p1000)**capa - else - sst(i,j) = spval - endif - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa) - -! foundation temperature - VarName='tref' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,fdnsst) - if(debugprint)print*,'sample ',VarName,' = ',fdnsst(isa,jsa) - -! GFS does not have time step and physics time step, make up ones since they -! are not really used anyway -! NPHS=1. -! DT=90. -! DTQ2 = DT * NPHS !MEB need to get physics DT - DTQ2 = DTP !MEB need to get physics DT - NPHS=1 - DT = DTQ2/NPHS !MEB need to get DT - TSPH = 3600./DT - -! convective precip in m per physics time step using getgb -! read 3 hour bucket - VarName='cpratb_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgcprate) -! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa) - -! print*,'maxval CPRATE: ', maxval(CPRATE) - -! read continuous bucket - VarName='cprat_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgcprate_cont) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (avgcprate_cont(i,j) /= spval) avgcprate_cont(i,j) = & - avgcprate_cont(i,j) * (dtq2*0.001) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcprate_cont(isa,jsa) - -! print*,'maxval CPRATE: ', maxval(CPRATE) - -! precip rate in m per physics time step using getgb - VarName='prateb_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgprec) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if(avgprec(i,j) /= spval)avgprec(i,j)=avgprec(i,j)*(dtq2*0.001) - enddo - enddo - - if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa) - -! prec = avgprec !set avg cprate to inst one to derive other fields - - VarName='prate_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgprec_cont) -! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (avgprec_cont(i,j) /=spval)avgprec_cont(i,j)=avgprec_cont(i,j) & - * (dtq2*0.001) - enddo - enddo - - if(debugprint)print*,'sample ',VarName,' = ',avgprec_cont(isa,jsa) -! precip rate in m per physics time step - VarName='tprcp' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,prec) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (prec(i,j) /= spval) prec(i,j)=prec(i,j)* (dtq2*0.001) & - * 1000. / dtp - enddo - enddo - -! convective precip rate in m per physics time step - VarName='cnvprcp' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,cprate) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (cprate(i,j) /= spval) then - cprate(i,j) = max(0.,cprate(i,j)) * (dtq2*0.001) & - * 1000. / dtp - else - cprate(i,j) = 0. - endif - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',cprate(isa,jsa) - -! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f - -! max hourly 1-km agl reflectivity -! VarName='refdmax' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refd_max) -! if(debugprint)print*,'sample ',VarName,' = ',refd_max(isa,jsa) -! max hourly -10C reflectivity -! VarName='refdmax263k' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refdm10c_max) -! if(debugprint)print*,'sample ',VarName,' = ',refdm10c_max(isa,jsa) - -! max hourly u comp of 10m agl wind -! VarName='u10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,u10max) -! if(debugprint)print*,'sample ',VarName,' = ',u10max(isa,jsa) -! max hourly v comp of 10m agl wind -! VarName='v10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,v10max) -! if(debugprint)print*,'sample ',VarName,' = ',v10max(isa,jsa) -! max hourly 10m agl wind speed -! VarName='spd10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,wspd10max) -! if(debugprint)print*,'sample ',VarName,' = ',wspd10max(isa,jsa) - - -! 2m T using nemsio - VarName='tmp2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,tshltr) - if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) - -! inst snow water eqivalent using nemsio - VarName='weasd' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sno) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) == 1.0 .and. sice(i,j)==0.) sno(i,j) = spval - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa) - -! ave snow cover - VarName='snowc_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,snoavg) -! snow cover is multipled by 100 in SURFCE before writing it out - do j=jsta,jend - do i=ista,iend - if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j)=spval - if(snoavg(i,j)/=spval)snoavg(i,j)=snoavg(i,j)/100. - end do - end do - -! snow depth in mm using nemsio - VarName='snod' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,si) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval - if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 - CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency - lspa(i,j) = spval ! GFS does not have similated precip - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - Q10(i,j) = SPVAL ! GFS does not have 10 m humidity - ALBASE(i,j) = SPVAL ! GFS does not have snow free albedo - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa) - -! 2m T using nemsio - VarName='tmp2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,tshltr) - if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) - -! GFS does not have 2m pres, estimate it, also convert t to theta - Do j=jsta,jend - do i=ista,iend - PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample 2m T and P after scatter= ' -! + ,i,j,tshltr(i,j),pshltr(i,j) - end do - end do - -! 2m specific humidity using nemsio - VarName='spfh2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,qshltr) - if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa) - -! mid day avg albedo in fraction using nemsio -! VarName='albdosfc' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgalbedo) -!! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction -!!$omp parallel do private(i,j) -! do j=jsta,jend -! do i=ista,iend -! if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 -! enddo -! enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) - -! time averaged column cloud fractionusing nemsio - VarName='tcdc_aveclm' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgtcdc) -! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa) - -! GFS probably does not use zenith angle -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=ista_2l, iend_2u - Czen(i,j) = spval - CZMEAN(i,j) = SPVAL - enddo - enddo - -! maximum snow albedo in fraction using nemsio - VarName='snoalb' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,mxsnal) -! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa) - -! land fraction - VarName='lfrac' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,landfrac) - -! GFS probably does not use sigt4, set it to sig*t^4 -!$omp parallel do private(i,j,tlmh) - Do j=jsta,jend - do i=ista,iend - TLMH = T(I,J,LM) * T(I,J,LM) - Sigt4(i,j) = 5.67E-8 * TLMH * TLMH - End do - End do - -! TG is not used, skip it for now - -! GFS does not have inst cloud fraction for high, middle, and low cloud -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u - cfrach(i,j) = spval - cfracl(i,j) = spval - cfracm(i,j) = spval - enddo - enddo - -! ave high cloud fraction using nemsio - VarName='tcdc_avehcl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgcfrach) -! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa) - -! ave low cloud fraction using nemsio - VarName='tcdc_avelcl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgcfracl) -! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa) - -! ave middle cloud fraction using nemsio - VarName='tcdc_avemcl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgcfracm) -! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa) - -! inst convective cloud fraction using nemsio - VarName='tcdccnvcl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,cnvcfr) -! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa) - -! slope type using nemsio - VarName='sltyp' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,buf) -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=ista_2l,iend_2u - if (buf(i,j) < spval) then - islope(i,j) = nint(buf(i,j)) - else - islope(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa) - -! plant canopy sfc wtr in m - VarName='cnwat' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,cmc) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001 - if (sm(i,j) /= 0.0) cmc(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u - grnflx(i,j) = spval ! GFS does not have inst ground heat flux - enddo - enddo - -! frozen precip fraction using nemsio - VarName='cpofp' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sr) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if(sr(i,j) /= spval) then -!set range within (0,1) - sr(i,j)=min(1.,max(0.,sr(i,j))) - endif - enddo - enddo - -! sea ice skin temperature - VarName='tisfc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ti) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sice(i,j) == spval .or. sice(i,j) == 0.) ti(i,j)=spval - enddo - enddo - -! vegetation fraction in fraction. using nemsio - VarName='veg' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,vegfrc) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (vegfrc(i,j) /= spval) then - vegfrc(i,j) = vegfrc(i,j) * 0.01 - else - vegfrc(i,j) = 0.0 - endif - enddo - enddo -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) vegfrc(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa) - -! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam - - SLDPTH(1) = 0.10 - SLDPTH(2) = 0.3 - SLDPTH(3) = 0.6 - SLDPTH(4) = 1.0 - -! liquid volumetric soil mpisture in fraction using nemsio - VarName='soill1' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sh2o(ista_2l,jsta_2l,1)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) sh2o(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1) - - VarName='soill2' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sh2o(ista_2l,jsta_2l,2)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) sh2o(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2) - - VarName='soill3' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sh2o(ista_2l,jsta_2l,3)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) sh2o(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3) - - VarName='soill4' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sh2o(ista_2l,jsta_2l,4)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) sh2o(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4) - -! volumetric soil moisture using nemsio - VarName='soilw1' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smc(ista_2l,jsta_2l,1)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) smc(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1) - - VarName='soilw2' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smc(ista_2l,jsta_2l,2)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) smc(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2) - - VarName='soilw3' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smc(ista_2l,jsta_2l,3)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) smc(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3) - - VarName='soilw4' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smc(ista_2l,jsta_2l,4)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) smc(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4) - -! soil temperature using nemsio - VarName='soilt1' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,stc(ista_2l,jsta_2l,1)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,1) = spval - !if (sm(i,j) /= 0.0) stc(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1) - - VarName='soilt2' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,stc(ista_2l,jsta_2l,2)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,2) = spval - !if (sm(i,j) /= 0.0) stc(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2) - - VarName='soilt3' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,stc(ista_2l,jsta_2l,3)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,3) = spval - !if (sm(i,j) /= 0.0) stc(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3) - - VarName='soilt4' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,stc(ista_2l,jsta_2l,4)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,4) = spval - !if (sm(i,j) /= 0.0) stc(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 - ncfrcv(i,j) = 1.0 - acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 - ncfrst(i,j) = 1.0 - bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF - rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave - enddo - enddo -! trdlw(i,j) = 6.0 - ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1 - -! time averaged incoming sfc longwave - VarName='dlwrf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,alwin) - -! inst incoming sfc longwave - VarName='dlwrf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,rlwin) - -! time averaged outgoing sfc longwave - VarName='ulwrf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,alwout) -! inst outgoing sfc longwave - VarName='ulwrf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,radot) - -! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa) - -! time averaged outgoing model top longwave using gfsio - VarName='ulwrf_avetoa' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,alwtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa) - -! GFS incoming sfc longwave has been averaged, set ARDLW to 1 - ardsw=1.0 -! trdsw=6.0 - -! time averaged incoming sfc shortwave - VarName='dswrf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswin) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa) - -! inst incoming sfc shortwave - VarName='dswrf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,rswin) - -! inst incoming clear sky sfc shortwave - VarName='csdlf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,rswinc) - -! time averaged incoming sfc uv-b using getgb - VarName='duvb_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,auvbin) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa) - -! time averaged incoming sfc clear sky uv-b using getgb - VarName='cduvb_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,auvbinc) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa) - -! time averaged outgoing sfc shortwave using gfsio - VarName='uswrf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswout) -! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa) - -! inst outgoing sfc shortwave using gfsio - VarName='uswrf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,rswout) - -! time averaged model top incoming shortwave - VarName='dswrf_avetoa' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswintoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswintoa(isa,jsa) - -! time averaged model top outgoing shortwave - VarName='uswrf_avetoa' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa) - -! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux -! has reversed sign convention using gfsio - VarName='shtfl_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sfcshx) -! where (sfcshx /= spval)sfcshx=-sfcshx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa) - -! inst surface sensible heat flux - VarName='shtfl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,twbs) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (twbs(i,j) /= spval) twbs(i,j) = -twbs(i,j) - enddo - enddo - -! GFS surface flux has been averaged, set ASRFC to 1 - asrfc=1.0 -! tsrfc=6.0 - -! time averaged surface latent heat flux, multiplied by -1 because wrf model flux -! has reversed sign vonvention using gfsio - VarName='lhtfl_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sfclhx) -! where (sfclhx /= spval)sfclhx=-sfclhx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa) - -! inst surface latent heat flux - VarName='lhtfl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,qwbs) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (qwbs(i,j) /= spval) qwbs(i,j) = -qwbs(i,j) - enddo - enddo - - if(me==0)print*,'rdaod= ',rdaod -! inst aod550 optical depth - if(rdaod) then - VarName='aod550' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aod550) - - VarName='du_aod550' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,du_aod550) - - VarName='ss_aod550' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ss_aod550) - - VarName='su_aod550' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,su_aod550) - - VarName='oc_aod550' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,oc_aod550) - - VarName='bc_aod550' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,bc_aod550) - endif !end if rdaod - - -! time averaged ground heat flux using nemsio - VarName='gflux_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,subshx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa) - -! inst ground heat flux using nemsio - VarName='gflux' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,grnflx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval - enddo - enddo - -! time averaged zonal momentum flux using gfsio - VarName='uflx_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sfcux) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa) - -! time averaged meridional momentum flux using nemsio - VarName='vflx_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sfcvx) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa) - -! dong read in inst surface flux -! inst zonal momentum flux using gfsio -! VarName='uflx' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcuxi) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcuxi(isa,jsa) - -! inst meridional momentum flux using nemsio -! VarName='vflx' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcvxi) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvxi(isa,jsa) - - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u - sfcuvx(i,j) = spval ! GFS does not use total momentum flux - enddo - enddo - -! time averaged zonal gravity wave stress using nemsio - VarName='u-gwd_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,gtaux) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa) - -! time averaged meridional gravity wave stress using getgb - VarName='v-gwd_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,gtauy) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa) - -! time averaged accumulated potential evaporation - VarName='pevpr_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgpotevp) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa) - -! inst potential evaporation - VarName='pevpr' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,potevp) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval - enddo - enddo - - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u -! GFS does not have temperature tendency due to long wave radiation - rlwtt(i,j,l) = spval -! GFS does not have temperature tendency due to short wave radiation - rswtt(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from convection - tcucn(i,j,l) = spval - tcucns(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from grid scale - train(i,j,l) = spval - enddo - enddo - enddo - -! set avrain to 1 - avrain=1.0 - avcnvc=1.0 - theat=6.0 ! just in case GFS decides to output T tendency - -! 10 m u using nemsio - VarName='ugrd10m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,u10) - - do j=jsta,jend - do i=ista,iend - u10h(i,j)=u10(i,j) - end do - end do -! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa) - -! 10 m v using gfsio - VarName='vgrd10m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,v10) - - do j=jsta,jend - do i=ista,iend - v10h(i,j)=v10(i,j) - end do - end do -! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa) - -! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='vtype' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,buf) -! where (buf /= spval) -! ivgtyp=nint(buf) -! elsewhere -! ivgtyp=0 !need to feed reasonable value to crtm -! end where -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=ista_2l,iend_2u - if (buf(i,j) < spval) then - ivgtyp(i,j) = nint(buf(i,j)) - else - ivgtyp(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa) - -! soil type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='sotyp' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,buf) -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=ista_2l,iend_2u - if (buf(i,j) < spval) then - isltyp(i,j) = nint(buf(i,j)) - else - isltyp(i,j) = 0 !need to feed reasonable value to crtm - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u - smstav(i,j) = spval ! GFS does not have soil moisture availability -! smstot(i,j) = spval ! GFS does not have total soil moisture - sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation - acsnow(i,j) = spval ! GFS does not have averaged accumulated snow - acsnom(i,j) = spval ! GFS does not have snow melt -! sst(i,j) = spval ! GFS does not have sst???? - thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute - qz0(i,j) = spval ! GFS does not output humidity at roughness length - uz0(i,j) = spval ! GFS does not output u at roughness length - vz0(i,j) = spval ! GFS does not output humidity at roughness length - enddo - enddo - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u - EL_PBL(i,j,l) = spval ! GFS does not have mixing length - exch_h(i,j,l) = spval ! GFS does not output exchange coefficient - enddo - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa) - -! retrieve inst convective cloud top, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index -! VarName='pres' -! VcoordName='convect-cld top' -! l=1 -! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa) - VarName='prescnvclt' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ptop) - - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - htop(i,j) = spval - if(ptop(i,j) <= 0.0) ptop(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=ista,iend - if(ptop(i,j) < spval)then - do l=1,lm - if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j) = l -! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', & -! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j) - exit - end if - end do - end if - end do - end do - -! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index - VarName='prescnvclb' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pbot) -! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - hbot(i,j) = spval - if(pbot(i,j) <= 0.0) pbot(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=ista,iend -! if(.not.lb(i,j))print*,'false bitmask for pbot at ' -! + ,i,j,pbot(i,j) - if(pbot(i,j) < spval)then - do l=lm,1,-1 - if(pbot(i,j) >= pmid(i,j,l)) then - hbot(i,j) = l -! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', & -! pbot(i,j),pmid(i,j,l),hbot(i,j) - exit - end if - end do - end if - end do - end do - if(debugprint)print*,'sample hbot = ',hbot(isa,jsa) -! retrieve time averaged low cloud top pressure using nemsio - VarName='pres_avelct' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ptopl) -! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa) - -! retrieve time averaged low cloud bottom pressure using nemsio - VarName='pres_avelcb' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pbotl) -! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa) - -! retrieve time averaged low cloud top temperature using nemsio - VarName='tmp_avelct' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,Ttopl) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa) - -! retrieve time averaged middle cloud top pressure using nemsio - VarName='pres_avemct' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ptopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa) - -! retrieve time averaged middle cloud bottom pressure using nemsio - VarName='pres_avemcb' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pbotm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa) - -! retrieve time averaged middle cloud top temperature using nemsio - VarName='tmp_avemct' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,Ttopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa) - -! retrieve time averaged high cloud top pressure using nemsio ********* - VarName='pres_avehct' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ptoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa) - -! retrieve time averaged high cloud bottom pressure using nemsio - VarName='pres_avehcb' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pboth) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa) - -! retrieve time averaged high cloud top temperature using nemsio - VarName='tmp_avehct' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,Ttoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa) - -! retrieve boundary layer cloud cover using nemsio - VarName='tcdc_avebndcl' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pblcfr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa) -! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=ista_2l,iend_2u - if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01 - enddo - enddo - -! retrieve cloud work function - VarName='cwork_aveclm' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,cldwork) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa) - -! accumulated total (base+surface) runoff - VarName='watr_acc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,runoff) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) runoff(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa) - -! accumulated evaporation of intercepted water - VarName='ecan_acc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,tecan) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) tecan(i,j) = spval - enddo - enddo - -! accumulated plant transpiration - VarName='etran_acc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,tetran) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) tetran(i,j) = spval - enddo - enddo - -! accumulated soil surface evaporation - VarName='edir_acc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,tedir) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) tedir(i,j) = spval - enddo - enddo - -! total water storage in aquifer - VarName='wa_acc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,twa) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) twa(i,j) = spval - enddo - enddo - -! retrieve shelter max temperature using nemsio - VarName='tmax_max2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,maxtshltr) - -! retrieve shelter min temperature using nemsio - VarName='tmin_min2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,mintshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & -! 1,mintshltr(im/2,(jsta+jend)/2) - -! retrieve shelter max RH -! VarName='rh02max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxrhshltr) - -! retrieve shelter min temperature using nemsio -! VarName='rh02min' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,minrhshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & -! 1,mintshltr(im/2,(jsta+jend)/2) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=ista_2l,iend_2u - MAXRHSHLTR(i,j) = SPVAL - MINRHSHLTR(i,j) = SPVAL - enddo - enddo - -! retrieve ice thickness using nemsio - VarName='icetk' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,dzice) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa) - -! retrieve wilting point using nemsio - VarName='wilt' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smcwlt) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) smcwlt(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa) - -! retrieve sunshine duration using nemsio - VarName='sunsd_acc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,suntime) - -! retrieve field capacity using nemsio - VarName='fldcp' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,fieldcapa) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) fieldcapa(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa) - -! retrieve time averaged surface visible beam downward solar flux - VarName='vbdsf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avisbeamswin) - l=1 - -! retrieve time averaged surface visible diffuse downward solar flux - VarName='vddsf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avisdiffswin) - -! retrieve time averaged surface near IR beam downward solar flux - VarName='nbdsf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,airbeamswin) - -! retrieve time averaged surface near IR diffuse downward solar flux - VarName='nddsf_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,airdiffswin) - -! retrieve time averaged surface clear sky outgoing LW - VarName='csulf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,alwoutc) - -! retrieve time averaged TOA clear sky outgoing LW - VarName='csulftoa' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,alwtoac) - -! retrieve time averaged surface clear sky outgoing SW - VarName='csusf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswoutc) - -! retrieve time averaged TOA clear sky outgoing LW - VarName='csusftoa' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswtoac) - -! retrieve time averaged surface clear sky incoming LW - VarName='csdlf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,alwinc) - -! retrieve time averaged surface clear sky incoming SW - VarName='csdsf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswinc) - -! retrieve shelter max specific humidity using nemsio - VarName='spfhmax_max2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,maxqshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', -! 1,maxqshltr(isa,jsa) - -! retrieve shelter min temperature using nemsio - VarName='spfhmin_min2m' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,minqshltr) - -! retrieve storm runoff using nemsio - VarName='ssrun_acc' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,SSROFF) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) ssroff(i,j) = spval - enddo - enddo - -! retrieve direct soil evaporation - VarName='evbs_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgedir) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) avgedir(i,j) = spval - enddo - enddo - -! retrieve CANOPY WATER EVAP - VarName='evcw_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgecan) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) avgecan(i,j) = spval - enddo - enddo - -! retrieve AVERAGED PRECIP ADVECTED HEAT FLUX - VarName='pah_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,paha) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) paha(i,j) = spval - enddo - enddo - -! retrieve nstantaneous PRECIP ADVECTED HEAT FLUX - VarName='pahi' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pahi) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) pahi(i,j) = spval - enddo - enddo - -! retrieve PLANT TRANSPIRATION - VarName='trans_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgetrans) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) avgetrans(i,j) = spval - enddo - enddo - -! retrieve snow sublimation - VarName='sbsno_ave' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgesnow) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval - enddo - enddo - -! retrive total soil moisture - VarName='soilm' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smstot) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) smstot(i,j) = spval - enddo - enddo - -! retrieve snow phase change heat flux - VarName='snohf' - call read_netcdf_2d_para(ncid2d,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,snopcx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - if (sm(i,j) /= 0.0) snopcx(i,j) = spval - enddo - enddo - -! GFS does not have deep convective cloud top and bottom fields - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=ista,iend - HTOPD(i,j) = SPVAL - HBOTD(i,j) = SPVAL - HTOPS(i,j) = SPVAL - HBOTS(i,j) = SPVAL - CUPPT(i,j) = SPVAL - enddo - enddo - -! done with flux file, close it for now - Status=nf90_close(ncid2d) -! deallocate(tmp,recname,reclevtyp,reclev) - -! pos east - call collect_loc(gdlat,dummy) - if(me == 1)then - write(6,*) 'laststart,latlast,me B calling bcast=',latstart,latlast,me - endif - if(me == 0)then - latstart = nint(dummy(1,1)*gdsdegr) - latlast = nint(dummy(im,jm)*gdsdegr) - write(6,*) 'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,& - 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1) - end if - call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me - call collect_loc(gdlon,dummy) - if(me == 0)then - lonstart = nint(dummy(1,1)*gdsdegr) - lonlast = nint(dummy(im,jm)*gdsdegr) - end if - call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(lonlast, 1,MPI_INTEGER,0,mpi_comm_comp,irtn) - - write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast -! - -! generate look up table for lifted parcel calculations - - THL = 210. - PLQ = 70000. - pt_TBL = 10000. ! this is for 100 hPa added by Moorthi - - CALL TABLE(PTBL,TTBL,PT_TBL, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - -! -! - IF(ME == 0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -!$omp parallel do private(l) - DO L = 1,LSM - ALSL(L) = LOG(SPL(L)) - END DO -! -!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - if(me == 0)then - print*,'writing out igds' - igdout = 110 -! open(igdout,file='griddef.out',form='unformatted' -! + ,status='unknown') - if(maptype == 1)THEN ! Lambert conformal - WRITE(igdout)3 - WRITE(6,*)'igd(1)=',3 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ELSE IF(MAPTYPE == 2)THEN !Polar stereographic - WRITE(igdout)5 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 !Assume projection at +-90 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ! Note: The calculation of the map scale factor at the standard - ! lat/lon and the PSMAPF - ! Get map factor at 60 degrees (N or S) for PS projection, which will - ! be needed to correctly define the DX and DY values in the GRIB GDS - if (TRUELAT1 < 0.) THEN - LAT = -60. - else - LAT = 60. - end if - - CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF) - - ELSE IF(MAPTYPE == 3) THEN !Mercator - WRITE(igdout)1 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)latlast - WRITE(igdout)lonlast - WRITE(igdout)TRUELAT1 - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)255 - ELSE IF(MAPTYPE == 0 .OR. MAPTYPE == 203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - END IF - end if -! -! - - RETURN - END - - subroutine read_netcdf_3d_para(ncid,im,jm,ista,ista_2l,iend,iend_2u,jsta,jsta_2l,jend,jend_2u, & - spval,varname,buf,lm) - - use netcdf - use ctlblk_mod, only : me - use params_mod, only : small - implicit none - INCLUDE "mpif.h" - - character(len=20),intent(in) :: varname - real,intent(in) :: spval - integer,intent(in) :: ncid,im,jm,lm,jsta_2l,jend_2u,jsta,jend - integer,intent(in) :: ista_2l,iend_2u,ista,iend - real,intent(out) :: buf(ista_2l:iend_2u,jsta_2l:jend_2u,lm) - integer :: varid,iret,ii,jj,i,j,l,kk - integer :: start(3), count(3), stride(3) - real,parameter :: spval_netcdf=9.99e+20 - real :: fill_value - - iret = nf90_inq_varid(ncid,trim(varname),varid) - if (iret /= 0) then - if (me == 0) print*,VarName," not found -Assigned missing values" -!$omp parallel do private(i,j,l) - do l=1,lm - do j=jsta,jend - do i=ista,iend - buf(i,j,l)=spval - enddo - enddo - enddo - else - iret = nf90_get_att(ncid,varid,"_FillValue",fill_value) - if (iret /= 0) fill_value = spval_netcdf - start = (/ista,jsta,1/) - ii=iend-ista+1 - jj=jend-jsta+1 - count = (/ii,jj,lm/) - iret = nf90_get_var(ncid,varid,buf(ista:iend,jsta:jend,1:lm),start=start,count=count) - if (iret /= 0) then - print*," iret /=0, Error in reading varid " - endif - do l=1,lm - do j=jsta,jend - do i=ista,iend - if(abs(buf(i,j,l)-fill_value) con_g, fv => con_fvirt, rgas => con_rd, & @@ -80,7 +86,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 + 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 @@ -160,15 +167,14 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) real, allocatable :: wrk1(:,:), wrk2(:,:) real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), & qs2d(:,:), cw2d(:,:), cfr2d(:,:) - real(kind=4),allocatable :: vcoord4(:,:,:) real, dimension(lm+1) :: ak5, bk5 real*8, allocatable :: pm2d(:,:), pi2d(:,:) real, allocatable :: tmp(:) - real :: buf(im,jsta_2l:jend_2u) - real :: buf3d(im,jsta_2l:jend_2u,lm) + real :: buf(ista_2l:iend_2u,jsta_2l:jend_2u) + real :: buf3d(ista_2l:iend_2u,jsta_2l:jend_2u,lm) -! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & -! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) +! real buf(ista_2l:iend_2u,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & +! ,buf3d(ista_2l:iend_2u,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) real LAT integer isa, jsa, latghf, jtem, idvc, idsl, nvcoord, ip1, nn, npass @@ -235,137 +241,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 @@ -375,14 +381,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 @@ -617,9 +626,13 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) end if STANDLON = cenlon - print*,'lonstart,latstart,cenlon,cenlat,truelat1,truelat2,stadlon,dyval,dxval', & + print*,'lonstart,latstart,cenlon,cenlat,truelat1,truelat2, & + stadlon,dyval,dxval', & lonstart,latstart,cenlon,cenlat,truelat1,truelat2,standlon,dyval,dxval + else if(trim(varcharval)=='gaussian')then + MAPTYPE=4 + idrt=4 else ! setting default maptype MAPTYPE=0 idrt=0 @@ -636,7 +649,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 @@ -647,7 +660,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 @@ -677,7 +690,6 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) ! write(0,*)'nrec=',nrec !allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) allocate(glat1d(jm),glon1d(im)) - allocate(vcoord4(lm+1,3,2)) ! hardwire idate for now ! idate=(/2017,08,07,00,0,0,0,0/) @@ -712,7 +724,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) ! Jili Dong check output format for coordinate reading Status=nf90_inq_varid(ncid3d,'grid_xt',varid) Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) - if(numDims==1) then + if(numDims==1.and.modelname=="FV3R") then read_lonlat=.true. else read_lonlat=.false. @@ -733,7 +745,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 @@ -756,13 +768,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 @@ -802,7 +814,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 @@ -813,13 +825,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 @@ -1577,14 +1596,14 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) pt = ak5(1) do j=jsta,jend - do i=1,im + do i=ista,iend pint(i,j,1)= pt end do end do do l=2,lp1 do j=jsta,jend - do i=1,im + do i=ista,iend if (dpres(i,j,l-1) @file -! -!> SUBPROGRAM: UPP_PHYSICS -!! @author JMENG @date 2020-05-20 -!! -!! A collection of UPP subroutines for physics variables calculation. -!! -!! CALCAPE -!! Compute CAPE/CINS and other storm related variables. -!! -!! CALCAPE2 -!! Compute additional storm related variables. -!! -!! CALRH -!! CALRH_NAM -!! CALRH_GFS -!! CALRH_GSD -!! Compute RH using various algorithms. -!! The NAM v4.1.18 ALGORITHM (CALRH_NAM) is selected as default for -!! NMMB and FV3GFS, FV3GEFS, and FV3R for the UPP 2020 unification. -!! -!! CALRH_PW -!! Algorithm use at GSD for RUC and Rapid Refresh -!! -!! FPVSNEW -!! Compute saturation vapor pressure. -!! -!! TVIRTUAL -!! Compute virtual temperature. -!! -!! PROGRAM HISTORY LOG: -!! MAY, 2020 Jesse Meng Initial code -!!------------------------------------------------------------------------------------- -!! +!> +!> @brief upp_physics is a collection of UPP subroutines for physics variables calculation. +!> @author Jesse Meng @date 2020-05-20 + +!> calcape() computes CAPE/CINS and other storm related variables. +!> +!> calcape2() computes additional storm related variables. +!> +!> calrh(), calrh_nam(), calrh_gfs(), calrh_gsd() compute RH using various algorithms. +!> +!> The NAM v4.1.18 algorithm (calrh_nam()) is selected as default for +!> NMMB and FV3GFS, FV3GEFS, and FV3R for the UPP 2020 unification. +!> +!> calrh_pw() algorithm use at GSD for RUC and Rapid Refresh. +!> +!> fpvsnew() computes saturation vapor pressure. +!> +!> tvirtual() computes virtual temperature. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2020-05-20 | Jesse Meng | Initial +!> +!> @author Jesse Meng @date 2020-05-20 module upp_physics implicit none @@ -72,55 +64,35 @@ END SUBROUTINE CALRH ! !------------------------------------------------------------------------------------- ! - SUBROUTINE CALRH_NAM(P1,T1,Q1,RH) -! SUBROUTINE CALRH(P1,T1,Q1,RH) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALRH COMPUTES RELATIVE HUMIDITY -! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -! -! ABSTRACT: -! THIS ROUTINE COMPUTES RELATIVE HUMIDITY GIVEN PRESSURE, -! TEMPERATURE, SPECIFIC HUMIDITY. AN UPPER AND LOWER BOUND -! OF 100 AND 1 PERCENT RELATIVE HUMIDITY IS ENFORCED. WHEN -! THESE BOUNDS ARE APPLIED THE PASSED SPECIFIC HUMIDITY -! ARRAY IS ADJUSTED AS NECESSARY TO PRODUCE THE SET RELATIVE -! HUMIDITY. -! . -! -! PROGRAM HISTORY LOG: -! ??-??-?? DENNIS DEAVEN -! 92-12-22 RUSS TREADON - MODIFIED AS DESCRIBED ABOVE. -! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D -! 98-08-18 MIKE BALDWIN - MODIFY TO COMPUTE RH OVER ICE AS IN MODEL -! 98-12-16 GEOFF MANIKIN - UNDO RH COMPUTATION OVER ICE -! 00-01-04 JIM TUCCILLO - MPI VERSION -! 02-06-11 MIKE BALDWIN - WRF VERSION -! 06-03-19 Wen Meng - MODIFY TOP PRESSURE to 1 PA -! -! USAGE: CALL CALRH(P1,T1,Q1,RH) -! INPUT ARGUMENT LIST: -! P1 - PRESSURE (PA) -! T1 - TEMPERATURE (K) -! Q1 - SPECIFIC HUMIDITY (KG/KG) -! -! OUTPUT ARGUMENT LIST: -! RH - RELATIVE HUMIDITY (DECIMAL FORM) -! Q1 - ADJUSTED SPECIFIC HUMIDITY (KG/KG) -! -! OUTPUT FILES: -! NONE -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! LIBRARY: -! NONE -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! MACHINE : CRAY C-90 -!$$$ -! +!> calrh_nam() computes relative humidity. +!> +!> This routine computes relative humidity given pressure, +!> temperature, specific humidity. an upper and lower bound +!> of 100 and 1 percent relative humidity is enforced. When +!> these bounds are applied the passed specific humidity +!> array is adjusted as necessary to produce the set relative +!> humidity. +!> +!> @param[in] P1 Pressure (pa) +!> @param[in] T1 Temperature (K) +!> @param[in] Q1 Specific humidity (kg/kg) +!> @param[out] RH Relative humidity (decimal form) +!> @param[out] Q1 Specific humidity (kg/kg) +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> ????-??-?? | DENNIS DEAVEN | Initial +!> 1992-12-22 | Russ Treadon | Modified as described above +!> 1998-06-08 | T Black | Conversion from 1-D to 2-D +!> 1998-08-18 | Mike Baldwin | Modify to compute RH over ice as in model +!> 1998-12-16 | Geoff Manikin | undo RH computation over ice +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-06-11 | Mike Baldwin | WRF Version +!> 2006-03-19 | Wen Meng | Modify top pressure to 1 pa +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 + SUBROUTINE CALRH_NAM(P1,T1,Q1,RH) use params_mod, only: PQ0, a2, a3, a4, rhmin use ctlblk_mod, only: ista, iend, jsta, jend, spval !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -171,55 +143,37 @@ END SUBROUTINE CALRH_NAM ! !------------------------------------------------------------------------------------- ! +!> calrh_gfs() computes relative humidity. +!> +!> This routine computes relative humidity given pressure, +!> temperature, specific humidity. an upper and lower bound +!> of 100 and 1 percent relative humidity is enforced. When +!> these bounds are applied the passed specific humidity +!> array is adjusted as necessary to produce the set relative +!> humidity. +!> +!> @param[in] P1 Pressure (pa) +!> @param[in] T1 Temperature (K) +!> @param[in] Q1 Specific humidity (kg/kg) +!> @param[out] RH Relative humidity (decimal form) +!> @param[out] Q1 Specific humidity (kg/kg) +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> ????-??-?? | DENNIS DEAVEN | Initial +!> 1992-12-22 | Russ Treadon | Modified as described above +!> 1998-06-08 | T Black | Conversion from 1-D to 2-D +!> 1998-08-18 | Mike Baldwin | Modify to compute RH over ice as in model +!> 1998-12-16 | Geoff Manikin | undo RH computation over ice +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-06-11 | Mike Baldwin | WRF Version +!> 2013-08-13 | S. Moorthi | Threading +!> 2006-03-19 | Wen Meng | Modify top pressure to 1 pa +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 + SUBROUTINE CALRH_GFS(P1,T1,Q1,RH) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALRH COMPUTES RELATIVE HUMIDITY -! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -! -! ABSTRACT: -! THIS ROUTINE COMPUTES RELATIVE HUMIDITY GIVEN PRESSURE, -! TEMPERATURE, SPECIFIC HUMIDITY. AN UPPER AND LOWER BOUND -! OF 100 AND 1 PERCENT RELATIVE HUMIDITY IS ENFORCED. WHEN -! THESE BOUNDS ARE APPLIED THE PASSED SPECIFIC HUMIDITY -! ARRAY IS ADJUSTED AS NECESSARY TO PRODUCE THE SET RELATIVE -! HUMIDITY. -! . -! -! PROGRAM HISTORY LOG: -! ??-??-?? DENNIS DEAVEN -! 92-12-22 RUSS TREADON - MODIFIED AS DESCRIBED ABOVE. -! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D -! 98-08-18 MIKE BALDWIN - MODIFY TO COMPUTE RH OVER ICE AS IN MODEL -! 98-12-16 GEOFF MANIKIN - UNDO RH COMPUTATION OVER ICE -! 00-01-04 JIM TUCCILLO - MPI VERSION -! 02-06-11 MIKE BALDWIN - WRF VERSION -! 13-08-13 S. Moorthi - Threading -! 06-03-19 Wen Meng - MODIFY TOP PRESSURE to 1 PA -! -! USAGE: CALL CALRH(P1,T1,Q1,RH) -! INPUT ARGUMENT LIST: -! P1 - PRESSURE (PA) -! T1 - TEMPERATURE (K) -! Q1 - SPECIFIC HUMIDITY (KG/KG) -! -! OUTPUT ARGUMENT LIST: -! RH - RELATIVE HUMIDITY (DECIMAL FORM) -! Q1 - ADJUSTED SPECIFIC HUMIDITY (KG/KG) -! -! OUTPUT FILES: -! NONE -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! LIBRARY: -! NONE -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! MACHINE : CRAY C-90 -!$$$ -! use params_mod, only: rhmin use ctlblk_mod, only: ista, iend, jsta, jend, spval !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -390,37 +344,28 @@ END SUBROUTINE CALRH_PW !------------------------------------------------------------------------------------- ! elemental function fpvsnew(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsnew Compute saturation vapor pressure -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A linear interpolation is done between values in a lookup table -! computed in gpvs. See documentation for fpvsx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 6 decimal places. -! On the Cray, fpvs is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvs=fpvsnew(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsnew Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ +!> fpvsnew() computes saturation vapor pressure. +!> +!> Compute saturation vapor pressure from the temperature. +!> A linear interpolation is done between values in a lookup table +!> computed in gpvs. See documentation for fpvsx for details. +!> Input values outside table range are reset to table extrema. +!> The interpolation accuracy is almost 6 decimal places. +!> On the Cray, fpvs is about 4 times faster than exact calculation. +!> This function should be expanded inline in the calling routine. +!> +!> @param[in] t Real(krealfp) Temperature in Kelvin. +!> @param[out] fpvsnew Real(krealfp) Saturation vapor pressure in Pascals. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1991-05-07 | Iredell | Initial. Made into inlinable function +!> 1994-12-30 | Iredell | Expand table +!> 1999-03-01 | Iredell | F90 module +!> 2001-02-26 | Iredell | Ice phase +!> +!> @author N Phillips w/NMC2X2 @date 1982-12-30 implicit none integer,parameter:: nxpvs=7501 real,parameter:: con_ttp =2.7316e+2 ! temp at H2O 3pt @@ -490,130 +435,98 @@ elemental function fpvsnew(t) end function fpvsnew ! !------------------------------------------------------------------------------------- -! - +!> calcape() computes CAPE and CINS. +!> +!> This routine computes CAPE and CINS given temperature, +!> pressure, and specific humidty. In "storm and cloud +!> dynamics" (1989, academic press) cotton and anthes define +!> CAPE (equation 9.16, p501) as +!> +!> @code +!> EL +!> CAPE = SUM G * LN(THETAP/THETAA) DZ +!> LCL +!> +!> Where, +!> EL = Equilibrium level, +!> LCL = Lifting condenstation level, +!> G = Gravitational acceleration, +!> THETAP = Lifted parcel potential temperature, +!> THETAA = Ambient potential temperature. +!> @endcode +!> +!> Note that the integrand ln(THETAP/THETAA) approximately +!> equals (THETAP-THETAA)/THETAA. This ratio is often used +!> in the definition of CAPE/CINS. +!> +!> Two types of CAPE/CINS can be computed by this routine. The +!> summation process is the same For both cases. What differs +!> is the definition of the parcel to lift. FOR ITYPE=1 the +!> parcel with the warmest THETA-E in A DPBND pascal layer above +!> the model surface is lifted. the arrays P1D, T1D, and Q1D +!> are not used. For itype=2 the arrays P1D, T1D, and Q1D +!> define the parcel to lift in each column. Both types of +!> CAPE/CINS may be computed in a single execution of the post +!> processor. +!> +!> This algorithm proceeds as follows. +!> For each column, +!> (1) Initialize running CAPE and CINS SUM TO 0.0 +!> (2) Compute temperature and pressure at the LCL using +!> look up table (PTBL). Use either parcel that gives +!> max THETAE in lowest DPBND above ground (ITYPE=1) +!> or given parcel from t1D,Q1D,...(ITYPE=2). +!> (3) Compute the temp of a parcel lifted from the LCL. +!> We know that the parcel's +!> equivalent potential temperature (THESP) remains +!> constant through this process. we can +!> compute tpar using this knowledge using look +!> up table (subroutine TTBLEX). +!> (4) Find the equilibrium level. This is defined as the +!> highest positively buoyant layer. +!> (If there is no positively buoyant layer, CAPE/CINS +!> will be zero) +!> (5) Compute CAPE/CINS. +!> (A) Compute THETAP. We know TPAR and P. +!> (B) Compute THETAA. We know T and P. +!> (6) Add G*(THETAP-THETAA)*DZ to the running CAPE or CINS sum. +!> (A) If THETAP > THETAA, add to the CAPE sum. +!> (B) If THETAP < THETAA, add to the CINS sum. +!> (7) Are we at equilibrium level? +!> (A) If yes, stop the summation. +!> (b) if no, contiunue the summation. +!> (8) Enforce limits on CAPE and CINS (i.e. no negative CAPE) +!> +!> @param[in] ITYPE INTEGER Flag specifying how parcel to lift is identified. See comments above. +!> @param[in] DPBND Depth over which one searches for most unstable parcel. +!> @param[in] P1D Array of pressure of parcels to lift. +!> @param[in] T1D Array of temperature of parcels to lift. +!> @param[in] Q1D Array of specific humidity of parcels to lift. +!> @param[in] L1D Array of model level of parcels to lift. +!> @param[out] CAPE Convective available potential energy (J/kg). +!> @param[out] CINS Convective inhibition (J/kg). +!> @param[out] PPARC Pressure level of parcel lifted when one searches over a particular depth to compute CAPE/CIN. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-02-10 | Russ Treadon | Initial +!> 1993-06-19 | Russ Treadon | Generalized routine to allow for type 2 CAPE/CINS calculations +!> 1994-09-23 | Mike Baldwin | Modified to use look up tables instead of complicated equations +!> 1994-10-13 | Mike Baldwin | Modified to continue CAPE/CINS calc up to at highest buoyant layer +!> 1998-06-12 | T Black | Conversion from 1-D TO 2-D +!> 1998-08-18 | T Black | Compute APE internally +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-01-15 | Mike Baldwin | WRF Version +!> 2003-08-24 | G Manikin | Added level of parcel being lifted as output from the routine and added the depth over which one searches for the most unstable parcel as input +!> 2010-09-09 | G Manikin | Changed computation to use virtual temp added eq lvl hght and thunder parameter +!> 2015-??-?? | S Moorthi | Optimization and threading +!> 2021-07-28 | W Meng | Restrict computation from undefined grids +!> 2021-09-01 | E Colon | Equivalent level height index for RTMA +!> +!> @author Russ Treadon W/NP2 @date 1993-02-10 SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & CINS,PPARC,ZEQL,THUND) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALCAPE COMPUTES CAPE AND CINS -! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-02-10 -! -! ABSTRACT: -! -! THIS ROUTINE COMPUTES CAPE AND CINS GIVEN TEMPERATURE, -! PRESSURE, AND SPECIFIC HUMIDTY. IN "STORM AND CLOUD -! DYNAMICS" (1989, ACADEMIC PRESS) COTTON AND ANTHES DEFINE -! CAPE (EQUATION 9.16, P501) AS -! -! EL -! CAPE = SUM G * LN(THETAP/THETAA) DZ -! LCL -! -! WHERE, -! EL = EQUILIBRIUM LEVEL, -! LCL = LIFTING CONDENSTATION LEVEL, -! G = GRAVITATIONAL ACCELERATION, -! THETAP = LIFTED PARCEL POTENTIAL TEMPERATURE, -! THETAA = AMBIENT POTENTIAL TEMPERATURE. -! -! NOTE THAT THE INTEGRAND LN(THETAP/THETAA) APPROXIMATELY -! EQUALS (THETAP-THETAA)/THETAA. THIS RATIO IS OFTEN USED -! IN THE DEFINITION OF CAPE/CINS. -! -! TWO TYPES OF CAPE/CINS CAN BE COMPUTED BY THIS ROUTINE. THE -! SUMMATION PROCESS IS THE SAME FOR BOTH CASES. WHAT DIFFERS -! IS THE DEFINITION OF THE PARCEL TO LIFT. FOR ITYPE=1 THE -! PARCEL WITH THE WARMEST THETA-E IN A DPBND PASCAL LAYER ABOVE -! THE MODEL SURFACE IS LIFTED. THE ARRAYS P1D, T1D, AND Q1D -! ARE NOT USED. FOR ITYPE=2 THE ARRAYS P1D, T1D, AND Q1D -! DEFINE THE PARCEL TO LIFT IN EACH COLUMN. BOTH TYPES OF -! CAPE/CINS MAY BE COMPUTED IN A SINGLE EXECUTION OF THE POST -! PROCESSOR. -! -! THIS ALGORITHM PROCEEDS AS FOLLOWS. -! FOR EACH COLUMN, -! (1) INITIALIZE RUNNING CAPE AND CINS SUM TO 0.0 -! (2) COMPUTE TEMPERATURE AND PRESSURE AT THE LCL USING -! LOOK UP TABLE (PTBL). USE EITHER PARCEL THAT GIVES -! MAX THETAE IN LOWEST DPBND ABOVE GROUND (ITYPE=1) -! OR GIVEN PARCEL FROM T1D,Q1D,...(ITYPE=2). -! (3) COMPUTE THE TEMP OF A PARCEL LIFTED FROM THE LCL. -! WE KNOW THAT THE PARCEL'S -! EQUIVALENT POTENTIAL TEMPERATURE (THESP) REMAINS -! CONSTANT THROUGH THIS PROCESS. WE CAN -! COMPUTE TPAR USING THIS KNOWLEDGE USING LOOK -! UP TABLE (SUBROUTINE TTBLEX). -! (4) FIND THE EQUILIBRIUM LEVEL. THIS IS DEFINED AS THE -! HIGHEST POSITIVELY BUOYANT LAYER. -! (IF THERE IS NO POSITIVELY BUOYANT LAYER, CAPE/CINS -! WILL BE ZERO) -! (5) COMPUTE CAPE/CINS. -! (A) COMPUTE THETAP. WE KNOW TPAR AND P. -! (B) COMPUTE THETAA. WE KNOW T AND P. -! (6) ADD G*(THETAP-THETAA)*DZ TO THE RUNNING CAPE OR CINS SUM. -! (A) IF THETAP > THETAA, ADD TO THE CAPE SUM. -! (B) IF THETAP < THETAA, ADD TO THE CINS SUM. -! (7) ARE WE AT EQUILIBRIUM LEVEL? -! (A) IF YES, STOP THE SUMMATION. -! (B) IF NO, CONTIUNUE THE SUMMATION. -! (8) ENFORCE LIMITS ON CAPE AND CINS (I.E. NO NEGATIVE CAPE) -! -! PROGRAM HISTORY LOG: -! 93-02-10 RUSS TREADON -! 93-06-19 RUSS TREADON - GENERALIZED ROUTINE TO ALLOW FOR -! TYPE 2 CAPE/CINS CALCULATIONS. -! 94-09-23 MIKE BALDWIN - MODIFIED TO USE LOOK UP TABLES -! INSTEAD OF COMPLICATED EQUATIONS. -! 94-10-13 MIKE BALDWIN - MODIFIED TO CONTINUE CAPE/CINS CALC -! UP TO AT HIGHEST BUOYANT LAYER. -! 98-06-12 T BLACK - CONVERSION FROM 1-D TO 2-D -! 98-08-18 T BLACK - COMPUTE APE INTERNALLY -! 00-01-04 JIM TUCCILLO - MPI VERSION -! 02-01-15 MIKE BALDWIN - WRF VERSION -! 03-08-24 G MANIKIN - ADDED LEVEL OF PARCEL BEING LIFTED -! AS OUTPUT FROM THE ROUTINE AND ADDED -! THE DEPTH OVER WHICH ONE SEARCHES FOR -! THE MOST UNSTABLE PARCEL AS INPUT -! 10-09-09 G MANIKIN - CHANGED COMPUTATION TO USE VIRTUAL TEMP -! - ADDED EQ LVL HGHT AND THUNDER PARAMETER -! 15-xx-xx S MOORTHI - optimization and threading -! 21-07-28 W Meng - Restrict computation from undefined grids. -! 21-09-01 E COLON - equivalent level height index for RTMA -! -! USAGE: CALL CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, -! CINS,PPARC) -! INPUT ARGUMENT LIST: -! ITYPE - INTEGER FLAG SPECIFYING HOW PARCEL TO LIFT IS -! IDENTIFIED. SEE COMMENTS ABOVE. -! DPBND - DEPTH OVER WHICH ONE SEARCHES FOR MOST UNSTABLE PARCEL -! P1D - ARRAY OF PRESSURE OF PARCELS TO LIFT. -! T1D - ARRAY OF TEMPERATURE OF PARCELS TO LIFT. -! Q1D - ARRAY OF SPECIFIC HUMIDITY OF PARCELS TO LIFT. -! L1D - ARRAY OF MODEL LEVEL OF PARCELS TO LIFT. -! -! OUTPUT ARGUMENT LIST: -! CAPE - CONVECTIVE AVAILABLE POTENTIAL ENERGY (J/KG) -! CINS - CONVECTIVE INHIBITION (J/KG) -! PPARC - PRESSURE LEVEL OF PARCEL LIFTED WHEN ONE SEARCHES -! OVER A PARTICULAR DEPTH TO COMPUTE CAPE/CIN -! -! OUTPUT FILES: -! STDOUT - RUN TIME STANDARD OUT. -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! BOUND - BOUND (CLIP) DATA BETWEEN UPPER AND LOWER LIMTS. -! TTBLEX - LOOKUP TABLE ROUTINE TO GET T FROM THETAE AND P -! -! LIBRARY: -! COMMON - -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : CRAY C-90 -!$$$ -! use vrbls3d, only: pmid, t, q, zint use vrbls2d, only: teql,ieql use masks, only: lmh @@ -992,141 +905,106 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & ! END SUBROUTINE CALCAPE ! -!------------------------------------------------------------------------------------- ! +!------------------------------------------------------------------------------------- +!> calcape2() computes CAPE and CINS. +!> +!> This routine computes CAPE and CINS given temperature, +!> pressure, and specific humidty. In "storm and cloud +!> dynamics" (1989, academic press) cotton and anthes define +!> CAPE (equation 9.16, p501) as +!> +!> @code +!> EL +!> CAPE = SUM G * ln(THETAP/THETAA) DZ +!> LCL +!> +!> Where, +!> EL = Equilibrium level, +!> LCL = Lifting condenstation level, +!> G = Gravitational acceleration, +!> THETAP = Lifted parcel potential temperature, +!> THETAA = Ambient potential temperature. +!> @endcode +!> +!> Note that the integrand ln(THETAP/THETAA) approximately +!> equals (THETAP-THETAA)/THETAA. This ratio is often used +!> in the definition of CAPE/CINS. +!> +!> Two types of CAPE/CINS can be computed by this routine. The +!> summation process is the same For both cases. What differs +!> is the definition of the parcel to lift. FOR ITYPE=1 the +!> parcel with the warmest THETA-E in A DPBND pascal layer above +!> the model surface is lifted. the arrays P1D, T1D, and Q1D +!> are not used. For itype=2 the arrays P1D, T1D, and Q1D +!> define the parcel to lift in each column. Both types of +!> CAPE/CINS may be computed in a single execution of the post +!> processor. +!> +!> This algorithm proceeds as follows. +!> For each column, +!> (1) Initialize running CAPE and CINS SUM TO 0.0 +!> (2) Compute temperature and pressure at the LCL using +!> look up table (PTBL). Use either parcel that gives +!> max THETAE in lowest DPBND above ground (ITYPE=1) +!> or given parcel from t1D,Q1D,...(ITYPE=2). +!> (3) Compute the temp of a parcel lifted from the LCL. +!> We know that the parcel's +!> equivalent potential temperature (THESP) remains +!> constant through this process. we can +!> compute tpar using this knowledge using look +!> up table (subroutine TTBLEX). +!> (4) Find the equilibrium level. This is defined as the +!> highest positively buoyant layer. +!> (If there is no positively buoyant layer, CAPE/CINS +!> will be zero) +!> (5) Compute CAPE/CINS. +!> (A) Compute THETAP. We know TPAR and P. +!> (B) Compute THETAA. We know T and P. +!> (6) Add G*(THETAP-THETAA)*DZ to the running CAPE or CINS sum. +!> (A) If THETAP > THETAA, add to the CAPE sum. +!> (B) If THETAP < THETAA, add to the CINS sum. +!> (7) Are we at equilibrium level? +!> (A) If yes, stop the summation. +!> (b) if no, contiunue the summation. +!> (8) Enforce limits on CAPE and CINS (i.e. no negative CAPE) +!> +!> @param[in] ITYPE INTEGER Flag specifying how parcel to lift is identified. See comments above. +!> @param[in] DPBND Depth over which one searches for most unstable parcel. +!> @param[in] P1D Array of pressure of parcels to lift. +!> @param[in] T1D Array of temperature of parcels to lift. +!> @param[in] Q1D Array of specific humidity of parcels to lift. +!> @param[in] L1D Array of model level of parcels to lift. +!> @param[out] CAPE Convective available potential energy (J/kg). +!> @param[out] CINS Convective inhibition (J/kg). +!> @param[out] LFC level of free convection (m). +!> @param[out] ESRHL Lower bound to account for effective helicity calculation. +!> @param[out] ESRHH Upper bound to account for effective helicity calculation. +!> @param[out] DCAPE downdraft CAPE (J/KG). +!> @param[out] DGLD Dendritic growth layer depth (m). +!> @param[out] ESP Enhanced stretching potential. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-02-10 | Russ Treadon | Initial +!> 1993-06-19 | Russ Treadon | Generalized routine to allow for type 2 CAPE/CINS calculations +!> 1994-09-23 | Mike Baldwin | Modified to use look up tables instead of complicated equations +!> 1994-10-13 | Mike Baldwin | Modified to continue CAPE/CINS calc up to at highest buoyant layer +!> 1998-06-12 | T Black | Conversion from 1-D TO 2-D +!> 1998-08-18 | T Black | Compute APE internally +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-01-15 | Mike Baldwin | WRF Version +!> 2003-08-24 | G Manikin | Added level of parcel being lifted as output from the routine and added the depth over which one searches for the most unstable parcel as input +!> 2010-09-09 | G Manikin | Changed computation to use virtual temp added eq lvl hght and thunder parameter +!> 2015-??-?? | S Moorthi | Optimization and threading +!> 2021-09-03 | J Meng | Modified to add 0-3km CAPE/CINS, LFC, effective helicity, downdraft CAPE, dendritic growth layer depth, ESP +!> 2021-09-01 | E Colon | Equivalent level height index for RTMA +!> +!> @author Russ Treadon W/NP2 @date 1993-02-10 SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & CAPE,CINS,LFC,ESRHL,ESRHH, & DCAPE,DGLD,ESP) -! SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & -! CINS,PPARC,ZEQL,THUND) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALCAPE COMPUTES CAPE AND CINS -! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-02-10 -! -! ABSTRACT: -! -! THIS ROUTINE COMPUTES CAPE AND CINS GIVEN TEMPERATURE, -! PRESSURE, AND SPECIFIC HUMIDTY. IN "STORM AND CLOUD -! DYNAMICS" (1989, ACADEMIC PRESS) COTTON AND ANTHES DEFINE -! CAPE (EQUATION 9.16, P501) AS -! -! EL -! CAPE = SUM G * LN(THETAP/THETAA) DZ -! LCL -! -! WHERE, -! EL = EQUILIBRIUM LEVEL, -! LCL = LIFTING CONDENSTATION LEVEL, -! G = GRAVITATIONAL ACCELERATION, -! THETAP = LIFTED PARCEL POTENTIAL TEMPERATURE, -! THETAA = AMBIENT POTENTIAL TEMPERATURE. -! -! NOTE THAT THE INTEGRAND LN(THETAP/THETAA) APPROXIMATELY -! EQUALS (THETAP-THETAA)/THETAA. THIS RATIO IS OFTEN USED -! IN THE DEFINITION OF CAPE/CINS. -! -! TWO TYPES OF CAPE/CINS CAN BE COMPUTED BY THIS ROUTINE. THE -! SUMMATION PROCESS IS THE SAME FOR BOTH CASES. WHAT DIFFERS -! IS THE DEFINITION OF THE PARCEL TO LIFT. FOR ITYPE=1 THE -! PARCEL WITH THE WARMEST THETA-E IN A DPBND PASCAL LAYER ABOVE -! THE MODEL SURFACE IS LIFTED. THE ARRAYS P1D, T1D, AND Q1D -! ARE NOT USED. FOR ITYPE=2 THE ARRAYS P1D, T1D, AND Q1D -! DEFINE THE PARCEL TO LIFT IN EACH COLUMN. BOTH TYPES OF -! CAPE/CINS MAY BE COMPUTED IN A SINGLE EXECUTION OF THE POST -! PROCESSOR. -! -! THIS ALGORITHM PROCEEDS AS FOLLOWS. -! FOR EACH COLUMN, -! (1) INITIALIZE RUNNING CAPE AND CINS SUM TO 0.0 -! (2) COMPUTE TEMPERATURE AND PRESSURE AT THE LCL USING -! LOOK UP TABLE (PTBL). USE EITHER PARCEL THAT GIVES -! MAX THETAE IN LOWEST DPBND ABOVE GROUND (ITYPE=1) -! OR GIVEN PARCEL FROM T1D,Q1D,...(ITYPE=2). -! (3) COMPUTE THE TEMP OF A PARCEL LIFTED FROM THE LCL. -! WE KNOW THAT THE PARCEL'S -! EQUIVALENT POTENTIAL TEMPERATURE (THESP) REMAINS -! CONSTANT THROUGH THIS PROCESS. WE CAN -! COMPUTE TPAR USING THIS KNOWLEDGE USING LOOK -! UP TABLE (SUBROUTINE TTBLEX). -! (4) FIND THE EQUILIBRIUM LEVEL. THIS IS DEFINED AS THE -! HIGHEST POSITIVELY BUOYANT LAYER. -! (IF THERE IS NO POSITIVELY BUOYANT LAYER, CAPE/CINS -! WILL BE ZERO) -! (5) COMPUTE CAPE/CINS. -! (A) COMPUTE THETAP. WE KNOW TPAR AND P. -! (B) COMPUTE THETAA. WE KNOW T AND P. -! (6) ADD G*(THETAP-THETAA)*DZ TO THE RUNNING CAPE OR CINS SUM. -! (A) IF THETAP > THETAA, ADD TO THE CAPE SUM. -! (B) IF THETAP < THETAA, ADD TO THE CINS SUM. -! (7) ARE WE AT EQUILIBRIUM LEVEL? -! (A) IF YES, STOP THE SUMMATION. -! (B) IF NO, CONTIUNUE THE SUMMATION. -! (8) ENFORCE LIMITS ON CAPE AND CINS (I.E. NO NEGATIVE CAPE) -! -! PROGRAM HISTORY LOG: -! 93-02-10 RUSS TREADON -! 93-06-19 RUSS TREADON - GENERALIZED ROUTINE TO ALLOW FOR -! TYPE 2 CAPE/CINS CALCULATIONS. -! 94-09-23 MIKE BALDWIN - MODIFIED TO USE LOOK UP TABLES -! INSTEAD OF COMPLICATED EQUATIONS. -! 94-10-13 MIKE BALDWIN - MODIFIED TO CONTINUE CAPE/CINS CALC -! UP TO AT HIGHEST BUOYANT LAYER. -! 98-06-12 T BLACK - CONVERSION FROM 1-D TO 2-D -! 98-08-18 T BLACK - COMPUTE APE INTERNALLY -! 00-01-04 JIM TUCCILLO - MPI VERSION -! 02-01-15 MIKE BALDWIN - WRF VERSION -! 03-08-24 G MANIKIN - ADDED LEVEL OF PARCEL BEING LIFTED -! AS OUTPUT FROM THE ROUTINE AND ADDED -! THE DEPTH OVER WHICH ONE SEARCHES FOR -! THE MOST UNSTABLE PARCEL AS INPUT -! 10-09-09 G MANIKIN - CHANGED COMPUTATION TO USE VIRTUAL TEMP -! - ADDED EQ LVL HGHT AND THUNDER PARAMETER -! 15-xx-xx S MOORTHI - optimization and threading -! 19-09-03 J MENG - MODIFIED TO ADD 0-3KM CAPE/CINS, LFC, -! EFFECTIVE HELICITY, DOWNDRAFT CAPE, -! DENDRITIC GROWTH LAYER DEPTH, ESP -! 21-09-01 E COLON - equivalent level height index for RTMA -! -! USAGE: CALL CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & -! CAPE,CINS,LFC,ESRHL,ESRHH, & -! DCAPE,DGLD,ESP) -! -! INPUT ARGUMENT LIST: -! ITYPE - INTEGER FLAG SPECIFYING HOW PARCEL TO LIFT IS -! IDENTIFIED. SEE COMMENTS ABOVE. -! DPBND - DEPTH OVER WHICH ONE SEARCHES FOR MOST UNSTABLE PARCEL -! P1D - ARRAY OF PRESSURE OF PARCELS TO LIFT. -! T1D - ARRAY OF TEMPERATURE OF PARCELS TO LIFT. -! Q1D - ARRAY OF SPECIFIC HUMIDITY OF PARCELS TO LIFT. -! L1D - ARRAY OF MODEL LEVEL OF PARCELS TO LIFT. -! -! OUTPUT ARGUMENT LIST: -! CAPE - CONVECTIVE AVAILABLE POTENTIAL ENERGY (J/KG) -! CINS - CONVECTIVE INHIBITION (J/KG) -! LFC - LEVEL OF FREE CONVECTION (M) -! ESRHL - LOWER BOUND TO ACCOUNT FOR EFFECTIVE HELICITY CALCULATION -! ESRHH - UPPER BOUND TO ACCOUNT FOR EFFECTIVE HELICITY CALCULATION -! DCAPE - DOWNDRAFT CAPE (J/KG) -! DGLD - DENDRITIC GROWTH LAYER DEPTH (M) -! ESP - ENHANCED STRETCHING POTENTIAL -! -! OUTPUT FILES: -! STDOUT - RUN TIME STANDARD OUT. -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! BOUND - BOUND (CLIP) DATA BETWEEN UPPER AND LOWER LIMTS. -! TTBLEX - LOOKUP TABLE ROUTINE TO GET T FROM THETAE AND P -! -! LIBRARY: -! COMMON - -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : CRAY C-90 -!$$$ -! use vrbls3d, only: pmid, t, q, zint use vrbls2d, only: fis,ieql use gridspec_mod, only: gridtype @@ -1793,54 +1671,31 @@ end function TVIRTUAL ! !------------------------------------------------------------------------------------- ! -! -!------------------------------------------------------------------------------------- -! - !> @file -! -!> SUBPROGRAM: CALVOR COMPUTES ABSOLUTE VORTICITY -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE ABSOLUTE VORTICITY. -!! -!! PROGRAM HISTORY LOG: -!! 92-12-22 RUSS TREADON -!! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-01-15 MIKE BALDWIN - WRF VERSION C-GRID -!! 05-03-01 H CHUANG - ADD NMM E GRID -!! 05-05-17 H CHUANG - ADD POTENTIAL VORTICITY CALCULATION -!! 05-07-07 B ZHOU - ADD RSM IN COMPUTING DVDX, DUDY AND UAVG -!! 13-08-09 S MOORTHI - Optimize the vorticity loop including threading -!! 16-08-05 S Moorthi - add zonal filetering -!! 2019-10-17 Y Mao - Skip calculation when U/V is SPVAL -!! 2020-11-06 J Meng - USE UPP_MATH MODULE -!! 21-09-02 Bo Cui - Decompose UPP in X direction, REPLACE EXCH_F to EXCH -!! 21-10-31 J MENG - 2D DECOMPOSITION -!! -!! USAGE: CALL CALVOR(UWND,VWND,ABSV) -!! INPUT ARGUMENT LIST: -!! UWND - U WIND (M/S) MASS-POINTS -!! VWND - V WIND (M/S) MASS-POINTS -!! -!! OUTPUT ARGUMENT LIST: -!! ABSV - ABSOLUTE VORTICITY (1/S) MASS-POINTS -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : WCOSS -!! +!> @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) ! @@ -2252,44 +2107,23 @@ SUBROUTINE CALVOR(UWND,VWND,ABSV) RETURN END +!> 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) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALDIV COMPUTES DIVERGENCE -! PRGRMMR: SAJAL KAR ORG: W/NP2 DATE: 16-05-05 -! -! ABSTRACT: -! FOR GFS, THIS ROUTINE COMPUTES THE HORIZONTAL DIVERGENCE -! USING 2ND-ORDER CENTERED SCHEME ON A LAT-LON GRID -! -! PROGRAM HISTORY LOG: -! 16-05-05 SAJAL KAR MODIFIED CALVORT TO COMPUTE DIVERGENCE FROM -! WIND COMPONENTS -! 16-07-22 S Moorthi modifying polar divergence calculation -! -! USAGE: CALL CALDIV(UWND,VWND,DIV) -! INPUT ARGUMENT LIST: -! UWND - U WIND (M/S) MASS-POINTS -! VWND - V WIND (M/S) MASS-POINTS -! -! OUTPUT ARGUMENT LIST: -! DIV - DIVERGENCE (1/S) MASS-POINTS -! -! OUTPUT FILES: -! NONE -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! NONE -! LIBRARY: -! COMMON - CTLBLK -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! MACHINE : WCOSS -!$$$ -! -! use masks, only: gdlat, gdlon use params_mod, only: d00, dtr, small, erad use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, & @@ -2560,41 +2394,21 @@ SUBROUTINE CALDIV(UWND,VWND,DIV) END SUBROUTINE CALDIV SUBROUTINE CALGRADPS(PS,PSX,PSY) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALGRADPS COMPUTES GRADIENTS OF A SCALAR FIELD PS OR LNPS -! PRGRMMR: SAJAL KAR ORG: W/NP2 DATE: 16-05-05 -! -! ABSTRACT: -! FOR GFS, THIS ROUTINE COMPUTES HRIZONTAL GRADIENTS OF PS OR LNPS -! USING 2ND-ORDER CENTERED SCHEME ON A LAT-LON GRID -! -! PROGRAM HISTORY LOG: -! 16-05-05 SAJAL KAR REDUCED FROM CALVORT TO ZONAL AND MERIDIONAL -! GRADIENTS OF GIVEN SURFACE PRESSURE PS, OR LNPS -! -! USAGE: CALL CALGRADPS(PS,PSX,PSY) -! INPUT ARGUMENT LIST: -! PS - SURFACE PRESSURE (PA) MASS-POINTS -! -! OUTPUT ARGUMENT LIST: -! PSX - ZONAL GRADIENT OF PS AT MASS-POINTS -! PSY - MERIDIONAL GRADIENT OF PS AT MASS-POINTS -! -! OUTPUT FILES: -! NONE -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! NONE -! LIBRARY: -! COMMON - CTLBLK -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! MACHINE : WCOSS -!$$$ -! +!> 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, & diff --git a/sorc/ncep_post.fd/VRBLS2D_mod.f b/sorc/ncep_post.fd/VRBLS2D_mod.f index aa3231177..134d014f1 100644 --- a/sorc/ncep_post.fd/VRBLS2D_mod.f +++ b/sorc/ncep_post.fd/VRBLS2D_mod.f @@ -82,7 +82,7 @@ module vrbls2d ,avgesnow(:,:),avgpotevp(:,:),avgprec_cont(:,:),avgcprate_cont(:,:)& ,ti(:,:),aod550(:,:),du_aod550(:,:),ss_aod550(:,:),su_aod550(:,:) & ,bc_aod550(:,:),oc_aod550(:,:),landfrac(:,:),paha(:,:),pahi(:,:) & - ,tecan(:,:),tetran(:,:),tedir(:,:),twa(:,:),fdnsst(:,:) + ,tecan(:,:),tetran(:,:),tedir(:,:),twa(:,:),fdnsst(:,:),pwat(:,:) integer, allocatable :: IVGTYP(:,:),ISLTYP(:,:),ISLOPE(:,:) & ,IEQL(:,:) diff --git a/sorc/ncep_post.fd/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f index bcce7e8f1..cedb5eba0 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -48,6 +48,7 @@ !! 21-11-03 Tracy Hertneky - Removed SIGIO option !! 22-01-14 W Meng - Remove interfaces INITPOST_GS_NEMS, INITPOST_NEMS_MPIIO !! INITPOST_NMM and INITPOST_GFS_NETCDF. +!! 22-03-15 W Meng - Unify FV3 based interfaces. !! !! USAGE: WRFPOST !! INPUT ARGUMENT LIST: @@ -146,11 +147,11 @@ PROGRAM WRFPOST use CTLBLK_mod, only: filenameaer, me, num_procs, num_servers, mpi_comm_comp, datestr, & mpi_comm_inter, filename, ioform, grib, idat, filenameflux, filenamed3d, gdsdegr, & spldef, modelname, ihrst, lsmdef,vtimeunits, tprec, pthresh, datahandle, im, jm, lm, & - lp1, lm1, im_jm, isf_surface_physics, nsoil, spl, lsmp1, global, & + lp1, lm1, im_jm, isf_surface_physics, nsoil, spl, lsmp1, global, imp_physics, & ista, iend, ista_m, iend_m, ista_2l, iend_2u, & jsta, jend, jsta_m, jend_m, jsta_2l, jend_2u, novegtype, icount_calmict, npset, datapd,& lsm, fld_info, etafld2_tim, eta2p_tim, mdl2sigma_tim, cldrad_tim, miscln_tim, & - mdl2agl_tim, mdl2std_tim, mdl2thandpv_tim, calrad_wcloud_tim, & + mdl2agl_tim, mdl2std_tim, mdl2thandpv_tim, calrad_wcloud_tim, & fixed_tim, time_output, imin, surfce2_tim, komax, ivegsrc, d3d_on, gocart_on,rdaod, & readxml_tim, spval, fullmodelname, submodelname, hyb_sigp, filenameflat, aqfcmaq_on,numx use grib2_module, only: gribit2,num_pset,nrecout,first_grbtbl,grib_info_finalize @@ -242,7 +243,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 (me==0) print*,'numx= ',numx ! if(MODELNAME == 'NMM')then ! read(5,1114) VTIMEUNITS ! 1114 format(a4) @@ -338,12 +339,18 @@ PROGRAM WRFPOST print*,'numx= ',numx endif - IF(TRIM(IOFORM) /= 'netcdfpara') THEN + 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 @@ -387,7 +394,7 @@ PROGRAM WRFPOST PTHRESH = 0.000001 end if !Chuang: add dynamical allocation - IF(TRIM(IOFORM) == 'netcdf') THEN + if(TRIM(IOFORM) == 'netcdf' .OR. TRIM(IOFORM) == 'netcdfpara') THEN IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR' .OR. MODELNAME == 'NMM') THEN call ext_ncd_ioinit(SysDepInfo,Status) print*,'called ioinit', Status @@ -431,14 +438,16 @@ PROGRAM WRFPOST call ext_ncd_ioclose ( DataHandle, Status ) ELSE -! use netcdf lib directly to read FV3 output in netCDF +! use parallel netcdf lib directly to read FV3 output in netCDF spval = 9.99e20 - Status = nf90_open(trim(fileName),NF90_NOWRITE, ncid3d) + Status = nf90_open(trim(fileName),IOR(NF90_NOWRITE,NF90_MPIIO), & + ncid3d,comm=mpi_comm_world,info=mpi_info_null) if ( Status /= 0 ) then print*,'error opening ',fileName, ' Status = ', Status stop endif - Status = nf90_open(trim(fileNameFlux),NF90_NOWRITE, ncid2d) + Status = nf90_open(trim(fileNameFlux),IOR(NF90_NOWRITE,NF90_MPIIO), & + ncid2d,comm=mpi_comm_world,info=mpi_info_null) if ( Status /= 0 ) then print*,'error opening ',fileNameFlux, ' Status = ', Status stop @@ -459,6 +468,13 @@ PROGRAM WRFPOST endif if(me==0)print*,'SF_SURFACE_PHYSICS= ',iSF_SURFACE_PHYSICS if(me==0)print*,'NSOIL= ',NSOIL +! read imp_physics + Status=nf90_get_att(ncid2d,nf90_global,'imp_physics',imp_physics) + if(Status/=0)then + print*,'imp_physics not found; assigning to GFDL 11' + imp_physics=11 + endif + if (me == 0) print*,'MP_PHYSICS= ',imp_physics ! get dimesions Status = nf90_inq_dimid(ncid3d,'grid_xt',varid) if ( Status /= 0 ) then @@ -499,53 +515,6 @@ PROGRAM WRFPOST print*,'im jm lm nsoil from fv3 output = ',im,jm,lm,nsoil END IF -! use netcdf_parallel lib directly to read FV3 output in netCDF - ELSE IF(TRIM(IOFORM) == 'netcdfpara') THEN - spval = 9.99e20 - Status = nf90_open(trim(fileName),ior(nf90_nowrite, nf90_mpiio), & - ncid3d, comm=mpi_comm_world, info=mpi_info_null) - if ( Status /= 0 ) then - print*,'error opening ',fileName, ' Status = ', Status - stop - endif -! get dimesions - Status = nf90_inq_dimid(ncid3d,'grid_xt',varid) - if ( Status /= 0 ) then - print*,Status,varid - STOP 1 - end if - Status = nf90_inquire_dimension(ncid3d,varid,len=im) - if ( Status /= 0 ) then - print*,Status - STOP 1 - end if - Status = nf90_inq_dimid(ncid3d,'grid_yt',varid) - if ( Status /= 0 ) then - print*,Status,varid - STOP 1 - end if - Status = nf90_inquire_dimension(ncid3d,varid,len=jm) - if ( Status /= 0 ) then - print*,Status - STOP 1 - end if - Status = nf90_inq_dimid(ncid3d,'pfull',varid) - if ( Status /= 0 ) then - print*,Status,varid - STOP 1 - end if - Status = nf90_inquire_dimension(ncid3d,varid,len=lm) - if ( Status /= 0 ) then - print*,Status - STOP 1 - end if - LP1 = LM+1 - LM1 = LM-1 - IM_JM = IM*JM -! set NSOIL to 4 as default for NOAH but change if using other -! SFC scheme - NSOIL = 4 - print*,'im jm lm nsoil from fv3 output = ',im,jm,lm,nsoil ELSE IF(TRIM(IOFORM) == 'binary' .OR. & TRIM(IOFORM) == 'binarympiio' ) THEN @@ -649,22 +618,18 @@ PROGRAM WRFPOST ! Reading model output for different models and IO format - IF(TRIM(IOFORM) == 'netcdf') THEN + IF(TRIM(IOFORM) == 'netcdf' .OR. TRIM(IOFORM) == 'netcdfpara') THEN IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR') THEN print*,'CALLING INITPOST TO PROCESS NCAR NETCDF OUTPUT' CALL INITPOST - ELSE IF (MODELNAME == 'FV3R') THEN -! use netcdf library to read output directly + ELSE IF (MODELNAME == 'FV3R' .OR. MODELNAME == 'GFS') THEN +! use parallel netcdf library to read output directly print*,'CALLING INITPOST_NETCDF' CALL INITPOST_NETCDF(ncid2d,ncid3d) ELSE PRINT*,'POST does not have netcdf option for model,',MODELNAME,' STOPPING,' STOP 9998 END IF -! use netcdf_parallel library to read fv3 output - ELSE IF(TRIM(IOFORM) == 'netcdfpara') THEN - print*,'CALLING INITPOST_GFS_NETCDF_PARA' - CALL INITPOST_GFS_NETCDF_PARA(ncid3d) ELSE IF(TRIM(IOFORM) == 'binarympiio') THEN IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR' .OR. MODELNAME == 'NMM') THEN print*,'WRF BINARY IO FORMAT IS NO LONGER SUPPORTED, STOPPING' diff --git a/tests/compile_upp.sh b/tests/compile_upp.sh index 7e9a9d310..2c20f660c 100755 --- a/tests/compile_upp.sh +++ b/tests/compile_upp.sh @@ -7,12 +7,13 @@ set -eu usage() { echo - echo "Usage: $0 [-g] [-w] -h" + echo "Usage: $0 [-p] [-g] [-w] [-v] [-c] -h" echo echo " -p installation prefix DEFAULT: ../install" - echo " -g Build with GTG(users with gtg repos. access only) DEFAULT: OFF" - echo " -w Build without WRF-IO DEFAULT: ON" - echo " -v Build with cmake verbose DEFAULT: NO" + echo " -g build with GTG(users with gtg repos. access only) DEFAULT: OFF" + echo " -w build without WRF-IO DEFAULT: ON" + echo " -v build with cmake verbose DEFAULT: NO" + echo " -c Compiler to use for build DEFAULT: intel" echo " -h display this message and quit" echo exit 1 @@ -21,8 +22,9 @@ usage() { prefix="../install" gtg_opt=" -DBUILD_WITH_GTG=OFF" wrfio_opt=" -DBUILD_WITH_WRFIO=ON" +compiler="intel" verbose_opt="" -while getopts ":p:gwvh" opt; do +while getopts ":p:gwc:vh" opt; do case $opt in p) prefix=$OPTARG @@ -33,6 +35,9 @@ while getopts ":p:gwvh" opt; do w) wrfio_opt=" -DBUILD_WITH_WRFIO=OFF" ;; + c) + compiler=$OPTARG + ;; v) verbose_opt="VERBOSE=1" ;; @@ -43,7 +48,6 @@ while getopts ":p:gwvh" opt; do done cmake_opts=" -DCMAKE_INSTALL_PREFIX=$prefix"${wrfio_opt}${gtg_opt} -hostname source ./detect_machine.sh if [[ $(uname -s) == Darwin ]]; then readonly MYDIR=$(cd "$(dirname "$(greadlink -f -n "${BASH_SOURCE[0]}" )" )" && pwd -P) @@ -60,7 +64,17 @@ if [[ $MACHINE_ID != "unknown" ]]; then module purge fi module use $PATHTR/modulefiles - modulefile=${MACHINE_ID} + if [[ $compiler == "intel" ]]; then + modulefile=${MACHINE_ID} + else + modulefile=${MACHINE_ID}_${compiler} + fi + if [ -f "${PATHTR}/modulefiles/${modulefile}" -o -f "${PATHTR}/modulefiles/${modulefile}.lua" ]; then + echo "Building for machine ${MACHINE_ID}, compiler ${compiler}" + else + echo "Modulefile does not exist for machine ${MACHINE_ID}, compiler ${compiler}" + exit 1 + fi module load $modulefile module list fi From 706da287e176f5825a630abe528b11a8a867fd2b Mon Sep 17 00:00:00 2001 From: Bo Cui Date: Mon, 2 May 2022 19:32:50 -0400 Subject: [PATCH 71/77] 20220502 Bo Cui code cleanup --- sorc/ncep_post.fd/COLLECT_LOC.f | 123 ++++---- sorc/ncep_post.fd/EXCH.f | 480 +++++++++++++++++--------------- sorc/ncep_post.fd/MPI_FIRST.f | 371 +++++++++++------------- 3 files changed, 463 insertions(+), 511 deletions(-) diff --git a/sorc/ncep_post.fd/COLLECT_LOC.f b/sorc/ncep_post.fd/COLLECT_LOC.f index 1fd6ea850..bcd005242 100644 --- a/sorc/ncep_post.fd/COLLECT_LOC.f +++ b/sorc/ncep_post.fd/COLLECT_LOC.f @@ -7,17 +7,18 @@ !> 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, & - buff,ista_2l,iend_2u,jexa,iexa,jsxa,isxa,ista,iend + jsta_2l, jend_2u, jm, me, & + buff,ista_2l,iend_2u,jexa,iexa,jsxa,isxa,ista,iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -26,8 +27,7 @@ SUBROUTINE COLLECT_LOC ( A, B ) real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: a real, dimension(im,jm), intent(out) :: b integer ierr,n - real, allocatable :: rbufs(:) - write(0,*) ' GWVX COLL CALL' + 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)) ) @@ -37,40 +37,43 @@ SUBROUTINE COLLECT_LOC ( A, B ) else !GWV reshape the receive subdomain - isum=1 - do jj=jsxa(me),jexa(me) - do ii=isxa(me),iexa(me) + + 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)' GWVX BOUNDS2 FAIL in reshape ',isum,ii,jj,im*jm,im,im*jm - rbufs(isum)=a(ii,jj) - isum=isum+1 - end do - end do + 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 -!UNCOMMENT POST TEST call mpi_gatherv(rbufs,icnt(me),MPI_REAL, buff,icnt,idsp,MPI_REAL,0,MPI_COMM_COMP, ierr ) - call mpi_gatherv(rbufs,icnt(me),MPI_REAL, buff,icnt,idsp,MPI_REAL,0,MPI_COMM_WORLD, ierr ) !GWVX COMMENT + 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 + + 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)' GWVX BOUNDS FAIL in reshape ',isum,ii,jj,im*jm,im,im*jm - 901 format(a30,10i10) - b(ii,jj)=buff(isum) - isum=isum+1 - end do + 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 do + end if + + endif ! num_procs <= 1 + + 901 format(a30,10i10) - end if - endif - deallocate(buff) - deallocate(rbufs) + deallocate(buff) + deallocate(rbufs) end ! @@ -78,7 +81,6 @@ SUBROUTINE COLLECT_LOC ( A, B ) ! 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 @@ -87,12 +89,10 @@ SUBROUTINE COLLECT_ALL ( A, B ) ! include 'mpif.h' integer ii,jj,isum -! real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: a real, dimension(ista:iend,jsta:jend), intent(in) :: a real, dimension(im,jm), intent(out) :: b integer ierr,n - real, allocatable :: rbufs(:) - write(0,*) ' GWVX COLL CALL' + 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)) ) @@ -102,44 +102,39 @@ SUBROUTINE COLLECT_ALL ( A, B ) else !GWV reshape the receive subdomain - isum=1 - do jj=jsxa(me),jexa(me) - do ii=isxa(me),iexa(me) + 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)' GWVX BOUNDS2 FAIL in reshape',isum,ii,jj,im*jm,im,im*jm + 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 + end do + end do !GWV end reshape -!UNCOMMENT POST TEST call mpi_gatherv(rbufs,icnt(me),MPI_REAL, -!buff,icnt,idsp,MPI_REAL,0,MPI_COMM_COMP, ierr ) -! call mpi_gatherv(rbufs,icnt(me),MPI_REAL, -! buff,icnt,idsp,MPI_REAL,0,mpi_comm_comp, ierr ) !GWVX COMMENT - call mpi_allgatherv(rbufs,icnt(me),MPI_REAL,buff,icnt,idsp,MPI_REAL, mpi_comm_comp, ierr ) !GWVX COMMENT - call mpi_barrier(mpi_comm_comp,ierr) + 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 -! if(me .eq. 0) then - isum=1 - do n=0,num_procs-1 - do jj=jsxa(n),jexa(n) + 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)' GWVX BOUNDS FAIL in reshape',isum,ii,jj,im*jm,im,im*jm - 901 format(a30,10i10) - b(ii,jj)=buff(isum) - isum=isum+1 - end do - end do + 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) -! end if - endif - deallocate(buff) - deallocate(rbufs) + deallocate(buff) + deallocate(rbufs) end diff --git a/sorc/ncep_post.fd/EXCH.f b/sorc/ncep_post.fd/EXCH.f index fbc67cdd2..b74bd5285 100644 --- a/sorc/ncep_post.fd/EXCH.f +++ b/sorc/ncep_post.fd/EXCH.f @@ -7,9 +7,10 @@ !> @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 @@ -17,27 +18,23 @@ !> !> @author Jim Tuccillo IBM @date 2000-01-06 SUBROUTINE EXCH(A) -! use ifcore - use ctlblk_mod, only: num_procs, jend, iup, jsta, idn, mpi_comm_comp, im,& - icoords,ibcoords,bufs,ibufs,me,numx, & ! GWV TMP - - jsta_2l, jend_2u,ileft,iright,ista_2l,iend_2u,ista,iend,jm,modelname + 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(:) + 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,j integer size,ubound,lbound integer msglenl, msglenr - integer i,ii,jj, ibl,ibu,jbl,jbu,icc,jcc !GWV + integer i,ii,jj, ibl,ibu,jbl,jbu,icc,jcc integer iwest,ieast integer ifirst @@ -46,8 +43,8 @@ SUBROUTINE EXCH(A) data ifirst/0/ allocate(coll(jm)) allocate(colr(jm)) - allocate(icolr(jm)) !GWV - allocate(icoll(jm)) !GWV + allocate(icolr(jm)) + allocate(icoll(jm)) ibl=max(ista-1,1) ibu=min(im,iend+1) jbu=min(jm,jend+1) @@ -61,173 +58,180 @@ SUBROUTINE EXCH(A) ! ! 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) !GWVB - if(iright .eq. MPI_PROC_NULL) iright=(me-numx) +1 !GWVB - endif + 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 + ! 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) + if ( ierr /= 0 ) then - print *, ' problem with first sendrecv in exch, ierr = ',ierr - stop 6661 + 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, & + 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 + 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 + end do + endif !IFIRST endif !checkcoords ! build the I columns to send and receive - 902 format(' GWVX EXCH BOUNDS ',18i8) + 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) -! if(ifirst .le. 0) icoll(j)=icoords(ista,j) !GWV TMP - end do + 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, & + + 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 + 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, & !GWV TMP - & icolr(jsta),msglenr ,MPI_INTEGER,iright,1, & !GWV TMP + 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 + if ( ierr /= 0 ) then + print *, ' problem with fourth sendrecv in exch, ierr = ',ierr + stop 7662 + endif endif !IFIRST - if(iright .ge. 0) then + 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) !GWV TMP + 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(iend+1 .eq. 3073) write(0,*) ' GWVX IBCOLL SETT2 ',iend+1,j,icolr(j),ii,jj !GWVX TMP -! if(iend+1 .eq. 3073 .and. ii .ne. 1) write(0,*) ' GWVX IBCOLL FAILED SETT2 ',iend+1,j,icolr(j),ii,jj !GWVX TMP - 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),' GWVX IEXCH COORD FAIL j,iend+1,ii,jj,ibcoord ' - 921 format(5i10,a50) - endif !IFIRST - endif !checkcoords -! - + 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 + endif ! for iright + + 921 format(5i10,a50) -! print *,'mype=',me,'in EXCH, after first mpi_sendrecv' +! print *,'mype=',me,'in EXCH, after first mpi_sendrecv' + if ( ierr /= 0 ) then - print *, ' problem with fifth sendrecv in exch, ierr = ',ierr - stop 6663 + print *, ' problem with fifth sendrecv in exch, ierr = ',ierr + stop 6663 end if jendp1 = min(jend+1,jend_2u) ! Moorthi + !GWV. change from full im row exchange to iend-ista+1 subrow exchange, -!GWVt of 2D decomp - do j=jsta,jend - colr(j)=a(iend,j) -! if(ifirst .le. 0) icolr(j)=icoords(iend,j) !GWV TMP - end do -! send first row to idown's last row+ and receive last row+ from iup's first row + + do j=jsta,jend + colr(j)=a(iend,j) + end do + +! send first row to idown's last row+ and receive last row+ from iup's first row + call mpi_sendrecv(a(ista,jsta),iend-ista+1,MPI_REAL,idn,1, & & a(ista,jendp1),iend-ista+1,MPI_REAL,iup,1, & & MPI_COMM_COMP,status,ierr) if ( ierr /= 0 ) then - print *, ' problem with sixth sendrecv in exch, ierr = ',ierr - stop 6664 + 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, & + 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 + 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 , & + +! 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, & + + 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 + if ( ierr /= 0 ) then + print *, ' problem with ninth sendrecv in exch, ierr = ',ierr + stop 7665 + endif endif !IFIRST - if(ileft .ge. 0) then + + 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) !GWV TMP -! write(0,*) ' GWVX IBCOLL SETT ',ista-1,j,icoll(j) - ii=ibcoords(ista-1,j)/10000 - jj=ibcoords( ista-1,j)-(ii*10000) + 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),' GWVX EXCH COORD FAIL j,ista-1,ii,jj,ibcoord ' + 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 + endif !checkcoords end do - - endif + 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) 'GWVX INFAILED IJ ',i,j,ibcoords(i,j),ibl,jbl,ibu,jbu - end do + 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 - endif !IFIRST - endif !checkcoords - + 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 @@ -239,12 +243,12 @@ SUBROUTINE EXCH(A) !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 + 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) @@ -253,141 +257,154 @@ SUBROUTINE EXCH(A) & 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 + 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 + 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 + 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 + print *, ' problem with thirteenth sendrecv in exch, ierr = ',ierr + stop 6774 endif -!GWV TEST - 139 format(a20,5(i10,i6,i6,'<>')) + + 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) + 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) - 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 .or. jj .ne. jcc .and. icc .ne. 0 ) write(0,151) ' CORNER FAIL ilb ll ',icc,jcc,ibcoords(icc,jcc),ii,jj - 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 .or. jj .ne. jcc .and. icc .ne. im+1 ) write(0,151) ' CORNER FAIL ilb ul ',icc,jcc,ibcoords(icc,jcc),ii,jj - 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 -! write(0,119) ileft,me,ibcoords(ista-1,jend+1),ibcoords(ista-1,jend-1),ista-1,jend-1,jend+1 !GWVX - 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 + + 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 - 151 format(a70,10i10) + + 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 -!bounds check + 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 + + 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 + + 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 + call mpi_barrier(mpi_comm_comp,ierr) + ifirst=ifirst+1 end !!@PROCESS NOCHECK @@ -409,7 +426,6 @@ subroutine exch_f(a) real,intent(inout) :: a ( im,jsta_2l:jend_2u ) integer status(MPI_STATUS_SIZE) integer ierr, jstam1, jendp1 -! write(0,*) ' called EXCH_F GWVX' ! if ( num_procs == 1 ) return ! diff --git a/sorc/ncep_post.fd/MPI_FIRST.f b/sorc/ncep_post.fd/MPI_FIRST.f index 692750172..35eeaa745 100644 --- a/sorc/ncep_post.fd/MPI_FIRST.f +++ b/sorc/ncep_post.fd/MPI_FIRST.f @@ -83,44 +83,32 @@ SUBROUTINE MPI_FIRST() pp10cb, ti use soil, only: smc, stc, sh2o, sldpth, rtdpth, sllevel use masks, only: htm, vtm, hbm2, sm, sice, lmh, gdlat, gdlon, dx, dy, lmv - use ctlblk_mod, only: me, num_procs, jm, jsta, jend, jsta_m, jsta_m2,ista,iend , & - jend_m, jend_m2, iup, idn, icnt, im, idsp, jsta_2l, jend_2u,idsp2,icnt2, & - jvend_2u, lm, lp1, jsta_2l, jend_2u, nsoil, nbin_du, nbin_ss, & + use ctlblk_mod, only: me, num_procs, jm, jsta, jend, jsta_m, jsta_m2,ista,iend , & + jend_m, jend_m2, iup, idn, icnt, im, idsp, jsta_2l, jend_2u,idsp2,icnt2, & + jvend_2u, lm, lp1, jsta_2l, jend_2u, nsoil, nbin_du, nbin_ss, & nbin_bc, nbin_oc, nbin_su, & - ISTA_M,IEND_M,ISTA_M2,IEND_M2, & - iSTA_M,IEND_M,ISTA_M2,IEND_M2, & - ileft,iright,ileftb,irightb , & - ibsize,ibsum, & - isxa,iexa,jsxa,jexa, & - icoords,ibcoords,bufs,ibufs, & ! GWV TMP - rbufs , & ! GWV TMP - rcoords,rbcoords, & ! GWV TMP - ISTA_2L, IEND_2U,IVEND_2U ,numx,MODELNAME + ISTA_M,IEND_M,ISTA_M2,IEND_M2, iSTA_M,IEND_M,ISTA_M2,IEND_M2, & + ileft,iright,ileftb,irightb,ibsize,ibsum, isxa,iexa,jsxa,jexa, & + icoords,ibcoords,bufs,ibufs, rbufs, rcoords,rbcoords, & + ISTA_2L, IEND_2U,IVEND_2U,numx,MODELNAME ! ! use params_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! include 'mpif.h' ! integer ierr,i,jsx,jex,isx,iex,j integer size,ubound,lbound integer isumm,isum ,ii,jj,isumm2 -! integer numx !number of subdomain in x direction integer , allocatable :: ibuff(:) real , allocatable :: rbuff(:) - integer, allocatable :: ipole(:),ipoles(:,:) - real , allocatable :: rpole(:),rpoles(:,:) -! integer ipoles(im,2),ipole(isx:iex) -! integer numx !number of subdomain in x direction + integer, allocatable :: ipole(:),ipoles(:,:) + real , allocatable :: rpole(:),rpoles(:,:) -! - isumm=0 - isumm2=0 -! numx=1 -! numx=1 + isumm=0 + isumm2=0 if ( me == 0 ) then write(0,*) ' NUM_PROCS,NUMX,NUMY = ',num_procs,numx,num_procs/numx @@ -131,19 +119,17 @@ SUBROUTINE MPI_FIRST() call mpi_abort(MPI_COMM_WORLD,1,ierr) stop end if -! + ! error check -! + if ( num_procs > JM/2 ) then print *, ' too many MPI tasks, max is ',jm/2,' stopping' call mpi_abort(MPI_COMM_WORLD,1,ierr) stop end if -! + ! global loop ranges ! -! call para_range(1,jm,num_procs,me,jsta,jend) -! GWVX temporary documentation ! para_range2 supports a 2D decomposition. The rest of the post ! supports 1D still and the call here is the special case where each ! processor gets all of the longitudes in the latitude 1D subdomain @@ -151,10 +137,10 @@ SUBROUTINE MPI_FIRST() ! argument (currently 1) and the Y decoposition will be specified by ! the fourth argument (currently all of the ranks) When X is ! subdivided the third and fourth arguments will have to be integral -! factors of num_procs and on 5/27/21 I am still working out a general -! way to do this if the user doesn't select the factors - ! call para_range2(im,jm,1,num_procs,me,ista,iend,jsta,jend) +! factors of num_procs + call para_range2(im,jm,numx,num_procs/numx,me,ista,iend,jsta,jend) + jsta_m = jsta jsta_m2 = jsta jend_m = jend @@ -184,39 +170,16 @@ SUBROUTINE MPI_FIRST() iend_m2=im-2 end if -! if ( me == 0 ) then -! jsta_m = 2 -! jsta_m2 = 3 -! ista_m = 2 -! ista_m2 = 3 -! end if -! if ( me == num_procs - 1 ) then -! jend_m = jm - 1 -! jend_m2 = jm - 2 -! iend_m = im - 1 -! iend_m2 = im - 2 -! end if -! -! neighbors -! -! print 102,me,ileft,iright,iup,idn,num_procs,'GWVX BOUNDS' - 102 format(6i10,a20) + 102 format(6i10,a20) -!! -! iup = me + 1 -! idn = me - 1 +! 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 -! ! 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 @@ -228,59 +191,55 @@ SUBROUTINE MPI_FIRST() 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 GWV COORDS test + 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 -! -! 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) ) +! 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 + 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) - if ( me == 0 ) then -!GWVXE print 196, ' GWVXX i, icnt(i),idsp(i) = ',i,icnt(i), & -!GWVXE idsp(i),icnt2(i),idsp2(i) - continue - end if - 196 format(a36,15i10) -!GWV Create send buffer for scatter. This is now needed because we are no + 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 + 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 + end do - end do + end do ! enddo of num_procs ! ! extraction limits -- set to two rows ! @@ -293,121 +252,109 @@ SUBROUTINE MPI_FIRST() 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 +! 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,numx) .eq. 0) Print *,' GWVX ILEFTB ',ileftb,me,numx - 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(mod(me+1,numx) .eq. 0 .or. me .eq. num_procs-1) print *,' GWVX IRIGHTB',irightb,me,numx - 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' + 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) + + 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 & + 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 & + call mpi_scatterv(rbuff,icnt,idsp,mpi_real & ,rbufs,icnt(me),mpi_real ,0,MPI_COMM_WORLD,j) ! !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 + + 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_2l,iend_2u - do i=ista,iend - ii=ibcoords(i,j)/10000 - jj=ibcoords( i,j)-(ii*10000) - if(ii .ne. i .or. jj .ne. j) 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) then print *,i,j,ii,jj,ibcoords(i,j),' GWVX FAIL ' - else -! print *,i,j,ii,jj,ibcoords(i,j),' GWVX SUCCESS' - continue - endif + else + continue + endif end do - end do - allocate(ipoles(im,2),ipole(ista:iend)) - allocate(rpoles(im,2),rpole(ista:iend)) -!GWVXE write (0,196) ' GWVX ISX IEX bounds',ista,iend,me,lbound(ipole),ubound(ipole) - ipole=9900000 - ipoles=-999999999 + end do + + allocate(ipoles(im,2),ipole(ista:iend)) + allocate(rpoles(im,2),rpole(ista:iend)) + ipole=9900000 + ipoles=-999999999 - do i=ista,iend -!`k do i=ista_2l,iend_2u -!!gwv if(me .lt. num_procs/2. .and. jsx .eq. 1 .or. me .gt. num_procs/2. & -!! .and. jex .eq. jm) write(0,196)' GWVXX bound',i,isx,iex,jm,9999,lbound(ibcoords),9999,ubound(ibcoords),9999,size(ipole) - 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) -!gwv if(me .lt. num_procs/2. .and. jsta_2l .le. 1 .and. icnt2(me) .gt. 0) print *,' GWVX ISET ',ipole(i),i,1,me - 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) -!gwv if(me .gt. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt. 0) print *,' GWVX ISET ',ipole(i),i,jm,me + 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 -!gwv if(i .lt. ista_2l) write(0,*) ' GWVXY I low ',i,999,lbound(ibcoords) -!gwv if(i .gt. iend_2u) write(0,*) ' GWVXY I high ',i,999,ubound(ibcoords) - continue - endif - if(me .gt. num_procs/2. .and. jend_2u .ge. jm) then -!gwv if(1 .lt. jsta_2l .and. me .lt. num_procs/2.) write(0,*) ' GWVXY J LOW ',jsta_2l,1 -! gwv if(jm .gt. jend_2u) write(0,*) ' GWVXY J HI ',jend_2u,jm - continue - endif -!end check code - end do + 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) - do i=0,num_procs-1 - if(me .eq. 0) print *,' GWVX IDSP2,icnt2',idsp2(i),icnt2(i) - end do - 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 -!GWVXE if(me .eq. 0) print 107,' GWVX IPOLES,i,j,ii,jj',i,j,ii,jj,ifix(rpoles(i,j)) - if(ii .ne. i .or. jj .ne. 1 .and. jj .ne. jm ) then - write(0,169)' GWVX IPOLES BAD POINT',rpoles(i,j),ii,i,jj,' jm= ',jm - else - continue -! write(0,169)' GWVX IPOLES GOOD POINT',rpoles(i,j),ii,i,jj,' jm= ',jm - endif - 107 format(a20,10i10) - 169 format(a25,f20.1,3i10,a10,4i10) - end do - end do - endif + 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 ) -! -! -! FROM VRBLS3D + 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, & @@ -415,51 +362,45 @@ SUBROUTINE MPI_FIRST() write(0,'(A,5I10)') 'MPI_FIRST me,jsta,jend,ista,iend,=',me,jsta,jend,ista,iend end - subroutine sub(a) - return - 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, & ! GWV TMP + 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(:) - - + 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 !GWV + 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)) !GWV + 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) + 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_allgatherv(rpole(ista),icnt2(me),MPI_REAL,rpoles,icnt2,idsp2,MPI_REAL ,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) print *,' GWVX GATHERED POLES ', ierr - ! call mpi_bcast(rpoles,im*2,MPI_REAL,0,MPI_COMM_WORLD, ierr ) - ! if(me .eq. 0) print *,' JESSE BCAST POLES ', ierr + 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 + call mpi_barrier(mpi_comm_comp,ierr) + ifirst=1 end From a88d252bdd4bd698b3dff1008902a252c86ea1a7 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Thu, 12 May 2022 16:31:02 +0000 Subject: [PATCH 72/77] 20220512 Jesse Meng minor fix for INITPOST_GFS_NEMS_MPIIO.f calling EXCH --- sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f b/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f index 50776aa2e..cca50d7b2 100644 --- a/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f +++ b/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f @@ -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) From 5f72e8978a0a42c389a1d93e419ffecf51d64fa5 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Wed, 25 May 2022 21:19:27 +0000 Subject: [PATCH 73/77] 20220525 Jesse Meng minor fix to 2d_decomp syntax --- sorc/ncep_post.fd/CLDRAD.f | 12 ++++++------ sorc/ncep_post.fd/SURFCE.f | 4 ++-- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index 476946ee5..fb03d8752 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -5211,7 +5211,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = ISTA,IEND IF(BCEM(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) = 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 diff --git a/sorc/ncep_post.fd/SURFCE.f b/sorc/ncep_post.fd/SURFCE.f index ad294ffcb..47df11479 100644 --- a/sorc/ncep_post.fd/SURFCE.f +++ b/sorc/ncep_post.fd/SURFCE.f @@ -825,7 +825,7 @@ SUBROUTINE SURFCE jj = jsta+j-1 do i=1,iend-ista+1 ii = ista+i-1 - datapd(i,j,cfld) = PSFCAVG(i,jj) + datapd(i,j,cfld) = PSFCAVG(ii,jj) enddo enddo endif @@ -5678,7 +5678,7 @@ SUBROUTINE SURFCE ! dong add missing value GRID1 = spval IF(MODELNAME /= 'FV3R') & - CALL CALTAU(EGRID1(ista,jsta),EGRID2(ista,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 From b18aaabead7bc6682b7fda5214af0970f02584f4 Mon Sep 17 00:00:00 2001 From: Wen Meng Date: Tue, 7 Jun 2022 19:54:31 +0000 Subject: [PATCH 74/77] Update VERSION to 11.0.0 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From fb312cd14aa2d5555a9a45bd6ec7e5d45b142201 Mon Sep 17 00:00:00 2001 From: wx22mj Date: Tue, 7 Jun 2022 20:22:39 +0000 Subject: [PATCH 75/77] 20220607 Jesse Meng add variable declaration block in PARA_RANGE.f --- sorc/ncep_post.fd/PARA_RANGE.f | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/sorc/ncep_post.fd/PARA_RANGE.f b/sorc/ncep_post.fd/PARA_RANGE.f index 26c447947..d409bca13 100644 --- a/sorc/ncep_post.fd/PARA_RANGE.f +++ b/sorc/ncep_post.fd/PARA_RANGE.f @@ -59,12 +59,18 @@ SUBROUTINE PARA_RANGE (N1,N2,NPROCS,IRANK,ISTA,IEND) !! 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) +! print 101,n,ix,jx,ista,iend,jsta,jend +! 101 format(16i8) return end From 75905e9bddd6daac773f44af7550aa876ba11f9b Mon Sep 17 00:00:00 2001 From: Jesse Meng Date: Wed, 8 Jun 2022 08:58:29 -0500 Subject: [PATCH 76/77] 20220608 Jesse Meng remove blank spaces in sorc/ncep_post.fd/AllGETHERV_GSD.f --- sorc/ncep_post.fd/AllGETHERV_GSD.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sorc/ncep_post.fd/AllGETHERV_GSD.f b/sorc/ncep_post.fd/AllGETHERV_GSD.f index 43008353a..63aef1f8d 100644 --- a/sorc/ncep_post.fd/AllGETHERV_GSD.f +++ b/sorc/ncep_post.fd/AllGETHERV_GSD.f @@ -55,7 +55,7 @@ SUBROUTINE AllGETHERV(GRID1) ij=0 do j=1,JM - do i=1,IM + do i=1,IM ij=ij+1 GRID1(i,j)=ibufrecv(ij) enddo From 2b205eb52e53329502d6375ad232434de2520535 Mon Sep 17 00:00:00 2001 From: Kate Fossell Date: Wed, 8 Jun 2022 11:09:51 -0500 Subject: [PATCH 77/77] Add 2D decomp overview documentation (#6) * Add 2D decomp overview documentation * Update 2D overview --- docs/2D-decomp.md | 21 +++++++++++++++++++++ docs/Doxyfile.in | 1 + 2 files changed, 22 insertions(+) create mode 100644 docs/2D-decomp.md 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@