+!> If none of these conditions apply, mpi_alltoall could be used directly rather than this subprogram and would be more efficient.
+!> @note
+!> Example 1. Transpose a 1000 x 10000 matrix.
+!>
+!> include 'mpif.h' ! use mpi
+!> parameter(jt=1000,kt=10000) ! set problem size
+!> real,allocatable:: a(:,:),b(:,:) ! declare arrays
+!> call mpi_init(ierr) ! initialize mpi
+!> call mpi_comm_rank(MPI_COMM_WORLD,mpirank,ierr) ! get mpi rank
+!> call mpi_comm_size(MPI_COMM_WORLD,mpisize,ierr) ! get mpi size
+!> call mptgen(mpirank,mpisize,1,1,jt,j1,j2,jx,jm,jn) ! decompose output
+!> call mptgen(mpirank,mpisize,1,1,kt,k1,k2,kx,km,kn) ! decompose input
+!> allocate(a(jt,k1:k2),b(kt,j1:j2)) ! allocate arrays
+!> a=reshape((/((j+k,j=1,jt),k=k1,k2)/),(/jt,k2-k1+1/)) ! initialize input
+!> call mptranr4(MPI_COMM_WORLD,mpisize,1,1,1, ! transpose arrays
+!> & jm,jt,j2-j1+1,jt,km,k2-k1+1,kt,kt,a,b)
+!> print '(2i8,f16.1)',((k,j,b(k,j),k=2000,kt,2000), ! print some values
+!> & j=((j1-1)/200+1)*200,j2,200)
+!> call mpi_finalize(ierr) ! finalize mpi
+!> end
+!>
+!> This transpose took 0.6 seconds on 4 2-way winterhawk nodes.
+!> @note
+!> A 20000x10000 transpose took 3.4 seconds on 16 2-way winterhawk nodes.
+!> @note
+!> Thus a transpose may take about 1 second for every 16 Mb per node.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1999-02-12 | Mark Iredell | Initial
+!>
+!> @author Mark Iredell np23 @date 1999-02-12
+ subroutine mptranr4(mpicomm,mpisize,im,ida,idb,&
+ jm,jma,jmb,jda,km,kma,kmb,kdb,a,b,ta,tb)
use machine_post,only:kint_mpi
implicit none
include 'mpif.h'
diff --git a/sorc/ncep_post.fd/GFSPOSTSIG.F b/sorc/ncep_post.fd/GFSPOSTSIG.F
index 50b6f358a..5ca911777 100644
--- a/sorc/ncep_post.fd/GFSPOSTSIG.F
+++ b/sorc/ncep_post.fd/GFSPOSTSIG.F
@@ -1,77 +1,54 @@
!> @file
-!
-!> Subprogram: rtsig Read and transform sigma file
-!! Prgmmr: Iredell Org: np23 Date: 1999-10-18
-!!
-!! Abstract: This subprogram reads a sigma file and transforms
-!! the fields to a designated global grid.
-!!
-!! Program history log:
-!! 1999-10-18 Mark Iredell
-!! 2013-04-19 Jun Wang: add option to get tmp and ps(in pascal)
-!! from enthalpy and ps(cb) option
-!! 2013-05-06 Shrinivas Moorthi: Initialize midea to 0
-!! 2013-05-07 Shrinivas Moorthi: Remove mo3, mct, midea and define io3, ict etc
-!! correctly and get correct cloud condensate.
-!! 2013-08-02 Shrinivas Moorthi: Rewrote the whole routine to read the sigma
-!! file differently and to read all tracers
-!! Addedd sptezj for two 2d fields
-!! 2014-02-20 Shrinivas Moorthi: Modified conversion from spectral to grid
-!! taking advantage of threding in SP library.
-!! This really speeds up the code
-!! Also threaded loop for Temperature from Tv
-
-!!
-!! Usage: call rtsig(lusig,head,k1,k2,kgds,ijo,nct, &
-!! h,p,px,py,t,tx,ty,u,v,d,z,sh,o3,ct,iret,o,o2)
-!! Input argument list:
-!! lusig integer(sigio_intkind) sigma file unit number
-!! head type(sigio_head) sigma file header
-!! k1 integer first model level to return
-!! k2 integer last model level to return
-!! kgds integer (200) GDS to which to transform
-!! ijo integer dimension of output fields
-!! levs integer number of total vertical levels
-!! ntrac integer number of output tracers
-!! jcap integer number of waves
-!! lnt2 integer (jcap+1)*(jcap+2)
-!! Output argument list:
-!! h real (ijo) surface orography (m)
-!! p real (ijo) surface pressure (Pa)
-!! px real (ijo) log surface pressure x-gradient (1/m)
-!! py real (ijo) log surface pressure y-gradient (1/m)
-!! t real (ijo,k1:k2) temperature (K)
-!! tx real (ijo,k1:k2) virtual temperature x-gradient (K/m)
-!! ty real (ijo,k1:k2) virtual temperature y-gradient (K/m)
-!! u real (ijo,k1:k2) x-component wind (m/s)
-!! v real (ijo,k1:k2) y-component wind (m/s)
-!! d real (ijo,k1:k2) wind divergence (1/s)
-!! trc real (ijo,k1:k2,ntrac) tracers
-!! 1 = specific humidity (kg/kg)
-!! 2 = Ozone mixing ratio (kg/kg)
-!! 3 = cloud condensate mixing ratio (kg/kg)
-!! .
-!! .
-!! atomic oxyge, oxygen etc
-!!
-!! iret integer return code
-!!
-!! Modules used:
-!! sigio_r_module sigma file I/O
-!!
-!! Subprograms called:
-!! sigio_rrdati read sigma single data field
-!! sptez scalar spectral transform
-!! sptezd gradient spectral transform
-!! sptezm multiple scalar spectral transform
-!! sptezmv multiple vector spectral transform
-!!
-!! Attributes:
-!! Language: Fortran 90
-!!
-!!
-! Add Iredells subroutine to read sigma files
-!-------------------------------------------------------------------------------
+!>
+!> @brief rtsig() reads and transforms sigma file.
+!>
+!> This subprogram reads a sigma file and transforms
+!> the fields to a designated global grid.
+!> Add Iredells subroutine to read sigma files.
+!>
+!> @param[out] lusig integer(sigio_intkind) sigma file unit number.
+!> @param[out] head type(sigio_head) sigma file header.
+!> @param[out] k1 integer first model level to return.
+!> @param[out] k2 integer last model level to return.
+!> @param[out] kgds integer (200) GDS to which to transform.
+!> @param[out] ijo integer dimension of output fields.
+!> @param[out] levs integer number of total vertical levels.
+!> @param[out] ntrac integer number of output tracers.
+!> @param[out] jcap integer number of waves.
+!> @param[out] lnt2 integer (jcap+1)*(jcap+2).
+!> @param[out] h real (ijo) surface orography (m).
+!> @param[out] p real (ijo) surface pressure (Pa).
+!> @param[out] px real (ijo) log surface pressure x-gradient (1/m).
+!> @param[out] py real (ijo) log surface pressure y-gradient (1/m).
+!> @param[out] t real (ijo,k1:k2) temperature (K).
+!> @param[out] tx real (ijo,k1:k2) virtual temperature x-gradient (K/m).
+!> @param[out] ty real (ijo,k1:k2) virtual temperature y-gradient (K/m).
+!> @param[out] u real (ijo,k1:k2) x-component wind (m/s).
+!> @param[out] v real (ijo,k1:k2) y-component wind (m/s).
+!> @param[out] d real (ijo,k1:k2) wind divergence (1/s).
+!> @param[out] trc real (ijo,k1:k2,ntrac) tracers.
+!>
+!> 1 = specific humidity (kg/kg)
+!> 2 = Ozone mixing ratio (kg/kg)
+!> 3 = cloud condensate mixing ratio (kg/kg)
+!> .
+!> .
+!> atomic oxyge, oxygen etc
+!>
+!>
+!> @param[out] iret Integer return code.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1999-10-18 | Mark Iredell | Initial
+!> 2013-04-19 | Jun Wang | Add option to get tmp and ps(in pascal) from enthalpy and ps(cb) option
+!> 2013-05-06 | Shrinivas Moorthi | Initialize midea to 0
+!> 2013-05-07 | Shrinivas Moorthi | Remove mo3, mct, midea and define io3, ict etc correctly and get correct cloud condensate.
+!> 2013-08-02 | Shrinivas Moorthi | Rewrote the whole routine to read the sigma file differently and to read all tracers. Added sptezj for two 2d fields
+!> 2014-02-20 | Shrinivas Moorthi | Modified conversion from spectral to grid taking advantage of threding in SP library. This really speeds up the code. Also threaded loop for Temperature from Tv
+!>
+!> @author Mark Iredell np23 @date 1999-10-18
subroutine rtsig(lusig,head,k1,k2,kgds,ijo,levs,ntrac,jcap,lnt2,me, &
h,p,px,py,t,u,v,d,trc,iret)
@@ -248,43 +225,35 @@ subroutine rtsig(lusig,head,k1,k2,kgds,ijo,levs,ntrac,jcap,lnt2,me, &
end subroutine
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+!> modstuff() computes model coordinate dependent functions.
+!>
+!> This subprogram computes fields which depend on the model coordinate
+!> such as pressure thickness and vertical velocity.
+!>
+!> @param[in] km integer number of levels.
+!> @param[in] idvc integer vertical coordinate id (1 for sigma and 2 for hybrid).
+!> @param[in] idsl integer type of sigma structure (1 for phillips or 2 for mean).
+!> @param[in] nvcoord integer number of vertical coordinates.
+!> @param[in] vcoord real (km+1,nvcoord) vertical coordinates.
+!> @param[in] ps real surface pressure (Pa).
+!> @param[in] psx real log surface pressure x-gradient (1/m).
+!> @param[in] psy real log surface pressure y-gradient (1/m).
+!> @param[in] d real (km) wind divergence (1/s).
+!> @param[in] u real (km) x-component wind (m/s).
+!> @param[in] v real (km) y-component wind (m/s).
+!> @param[out] pi real (km+1) interface pressure (Pa).
+!> @param[out] pm real (km) mid-layer pressure (Pa).
+!> @param[out] om real (km) vertical velocity (Pa/s).
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1999-10-18 | Mark Iredell | Initial
+!> 2013-04-19 | Jun Wang | Add option to get pi by using 8 byte real computation
+!>
+!> @author Mark Iredell np23 @date 1999-10-18
subroutine modstuff(km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,&
pi,pm,om)
-!$$$ Subprogram documentation block
-!
-! Subprogram: modstuff Compute model coordinate dependent functions
-! Prgmmr: Iredell Org: np23 Date: 1999-10-18
-!
-! Abstract: This subprogram computes fields which depend on the model coordinate
-! such as pressure thickness and vertical velocity.
-!
-! Program history log:
-! 1999-10-18 Mark Iredell
-! 2013-04-19 Jun Wang: add option to get pi by using 8byte real computation
-!
-! Usage: call modstuff(km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,&
-! pd,pi,pm,os,om,px,py)
-! Input argument list:
-! km integer number of levels
-! idvc integer vertical coordinate id (1 for sigma and 2 for hybrid)
-! idsl integer type of sigma structure (1 for phillips or 2 for mean)
-! nvcoord integer number of vertical coordinates
-! vcoord real (km+1,nvcoord) vertical coordinates
-! ps real surface pressure (Pa)
-! psx real log surface pressure x-gradient (1/m)
-! psy real log surface pressure y-gradient (1/m)
-! d real (km) wind divergence (1/s)
-! u real (km) x-component wind (m/s)
-! v real (km) y-component wind (m/s)
-! Output argument list:
-! pi real (km+1) interface pressure (Pa)
-! pm real (km) mid-layer pressure (Pa)
-! om real (km) vertical velocity (Pa/s)
-!
-! Attributes:
-! Language: Fortran 90
-!
-!$$$
use sigio_module, only: sigio_modprd
implicit none
integer,intent(in):: km,idvc,idsl,nvcoord
@@ -331,46 +300,38 @@ subroutine modstuff(km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,&
end subroutine
!-------------------------------------------------------------------------------
+!> modstuff2() computes model coordinate dependent functions.
+!>
+!> This subprogram computes fields which depend on the model coordinate
+!> such as pressure thickness and vertical velocity.
+!>
+!> @param[in] im integer inner computational domain.
+!> @param[in] ix integer maximum inner dimension.
+!> @param[in] km integer number of levels.
+!> @param[in] idvc integer vertical coordinate id (1 for sigma and 2 for hybrid).
+!> @param[in] idsl integer type of sigma structure (1 for phillips or 2 for mean).
+!> @param[in] nvcoord integer number of vertical coordinates.
+!> @param[in] vcoord real (km+1,nvcoord) vertical coordinates.
+!> @param[in] ps real surface pressure (Pa).
+!> @param[in] psx real log surface pressure x-gradient (1/m).
+!> @param[in] psy real log surface pressure y-gradient (1/m).
+!> @param[in] d real (km) wind divergence (1/s).
+!> @param[in] u real (km) x-component wind (m/s).
+!> @param[in] v real (km) y-component wind (m/s).
+!> @param[out] pi real (km+1) interface pressure (Pa).
+!> @param[out] pm real (km) mid-layer pressure (Pa).
+!> @param[out] om real (km) vertical velocity (Pa/s).
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1999-10-18 | Mark Iredell | Initial
+!> 2013-04-19 | Jun Wang | Add option to get pi by using 8 byte real computation
+!> 2013-08-13 | Shrinivas Moorthi | Modified to include im points and thread
+!>
+!> @author Mark Iredell np23 @date 1999-10-18
subroutine modstuff2(im,ix,km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,&
pi,pm,om,me)
-!$$$ Subprogram documentation block
-!
-! Subprogram: modstuff Compute model coordinate dependent functions
-! Prgmmr: Iredell Org: np23 Date: 1999-10-18
-!
-! Abstract: This subprogram computes fields which depend on the model coordinate
-! such as pressure thickness and vertical velocity.
-!
-! Program history log:
-! 1999-10-18 Mark Iredell
-! 2013-04-19 Jun Wang: add option to get pi by using 8byte real computation
-! 2013-08-13 Shrinivas Moorthi - Modified to include im points and thread
-!
-! Usage: call modstuff(km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,&
-! pd,pi,pm,os,om,px,py)
-! Input argument list:
-! im integer - inner computational domain
-! ix integer - maximum inner dimension
-! km integer number of levels
-! idvc integer vertical coordinate id (1 for sigma and 2 for hybrid)
-! idsl integer type of sigma structure (1 for phillips or 2 for mean)
-! nvcoord integer number of vertical coordinates
-! vcoord real (km+1,nvcoord) vertical coordinates
-! ps real surface pressure (Pa)
-! psx real log surface pressure x-gradient (1/m)
-! psy real log surface pressure y-gradient (1/m)
-! d real (km) wind divergence (1/s)
-! u real (km) x-component wind (m/s)
-! v real (km) y-component wind (m/s)
-! Output argument list:
-! pi real (km+1) interface pressure (Pa)
-! pm real (km) mid-layer pressure (Pa)
-! om real (km) vertical velocity (Pa/s)
-!
-! Attributes:
-! Language: Fortran 90
-!
-!$$$
use sigio_module, only : sigio_modprd
implicit none
integer, intent(in) :: im,ix,km,idvc,idsl,nvcoord,me
@@ -443,61 +404,47 @@ subroutine modstuff2(im,ix,km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,&
end subroutine
!-----------------------------------------------------------------------
+!> trssc() transforms sigma spectral fields to grid.
+!>
+!> Transforms sigma spectral fields to grid and converts
+!> log surface pressure to surface pressure and virtual temperature
+!> to temperature.
+!>
+!> @param[in] jcap integer spectral truncation.
+!> @param[in] nc integer first dimension (nc>=(jcap+1)*(jcap+2)).
+!> @param[in] km integer number of levels.
+!> @param[in] ntrac integer number of tracers.
+!> @param[in] idvm integer mass variable id.
+!> @param[in] idrt integer data representation type.
+!> @param[in] lonb integer number of longitudes.
+!> @param[in] latb integer number of latitudes.
+!> @param[in] ijl integer horizontal dimension.
+!> @param[in] j1 integer first latitude.
+!> @param[in] j2 integer last latitude.
+!> @param[in] jc integer number of cpus.
+!> @param[in] szs real (nc) orography.
+!> @param[in] sps real (nc) log surface pressure.
+!> @param[in] st real (nc,levs) virtual temperature.
+!> @param[in] sd real (nc,levs) divergence.
+!> @param[in] sz real (nc,levs) vorticity.
+!> @param[in] sq real (nc,levs*ntrac) tracers.
+!> @param[out] zs real (ijl) orography.
+!> @param[out] ps real (ijl) surface pressure.
+!> @param[out] t real (ijl,km) temperature.
+!> @param[out] u real (ijl,km) zonal wind.
+!> @param[out] v real (ijl,km) meridional wind.
+!> @param[out] q real (ijl,km*ntrac) tracers.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1999-10-18 | Mark Iredell | Initial
+!>
+!> @author Mark Iredell w/nmc23 @date 1992-10-31
subroutine trssc(jcap,nc,km,ntrac,idvc,idvm,idsl,nvcoord,vcoord, &
cpi,idrt,lonb,latb,ijl,ijn,j1,j2,jc,chgq0, &
szs,sps,st,sd,sz,sq,gfszs,gfsps,gfsp,gfsdp, &
gfst,gfsu,gfsv,gfsq,gfsw)
-!$$$ subprogram documentation block
-!
-! subprogram: trssc transform sigma spectral fields to grid
-! prgmmr: iredell org: w/nmc23 date: 92-10-31
-!
-! abstract: transforms sigma spectral fields to grid and converts
-! log surface pressure to surface pressure and virtual temperature
-! to temperature.
-!
-! program history log:
-! 91-10-31 mark iredell
-!
-! usage: call trssc(jcap,nc,km,ntrac,idvm,
-! & idrt,lonb,latb,ijl,j1,j2,jc,
-! & szs,sps,st,sd,sz,sq,zs,ps,t,u,v,q)
-! input argument list:
-! jcap integer spectral truncation
-! nc integer first dimension (nc>=(jcap+1)*(jcap+2))
-! km integer number of levels
-! ntrac integer number of tracers
-! idvm integer mass variable id
-! idrt integer data representation type
-! lonb integer number of longitudes
-! latb integer number of latitudes
-! ijl integer horizontal dimension
-! j1 integer first latitude
-! j2 integer last latitude
-! jc integer number of cpus
-! szs real (nc) orography
-! sps real (nc) log surface pressure
-! st real (nc,levs) virtual temperature
-! sd real (nc,levs) divergence
-! sz real (nc,levs) vorticity
-! sq real (nc,levs*ntrac) tracers
-! output argument list:
-! zs real (ijl) orography
-! ps real (ijl) surface pressure
-! t real (ijl,km) temperature
-! u real (ijl,km) zonal wind
-! v real (ijl,km) meridional wind
-! q real (ijl,km*ntrac) tracers
-!
-! subprograms called:
-! sptran perform a scalar spherical transform
-!
-! attributes:
-! language: fortran
-!
-!c$$$
-!! use gfsio_module
-! use gfsio_rst
implicit none
integer,intent(in)::jcap,nc,km,ntrac,idvc,idvm,idsl,nvcoord,idrt,lonb,latb
integer,intent(in)::ijl,ijn,j1,j2,jc,chgq0
diff --git a/sorc/ncep_post.fd/GPVS.f b/sorc/ncep_post.fd/GPVS.f
index c60dd2f6d..3e91b7d3d 100644
--- a/sorc/ncep_post.fd/GPVS.f
+++ b/sorc/ncep_post.fd/GPVS.f
@@ -1,36 +1,24 @@
!> @file
-! . . .
-!> SUBPROGRAM: GPVS COMPUTE SATURATION VAPOR PRESSURE TABLE
-!! AUTHOR: N PHILLIPS W/NP2 DATE: 30 DEC 82
-!!
-!! ABSTRACT: COMPUTE SATURATION VAPOR PRESSURE TABLE AS A FUNCTION OF
-!! TEMPERATURE FOR THE TABLE LOOKUP FUNCTION FPVS.
-!! EXACT SATURATION VAPOR PRESSURES ARE CALCULATED IN SUBPROGRAM FPVSX.
-!! THE CURRENT IMPLEMENTATION COMPUTES A TABLE WITH A LENGTH
-!! OF 7501 FOR TEMPERATURES RANGING FROM 180.0 TO 330.0 KELVIN.
-!!
-!! PROGRAM HISTORY LOG:
-!! 91-05-07 IREDELL
-!! 94-12-30 IREDELL EXPAND TABLE
-!! 96-02-19 HONG ICE EFFECT
-!!
-!! USAGE: CALL GPVS
-!!
-!! SUBPROGRAMS CALLED:
-!! (FPVSX) - INLINABLE FUNCTION TO COMPUTE SATURATION VAPOR PRESSURE
-!!
-!! COMMON BLOCKS:
-!! COMPVS - SCALING PARAMETERS AND TABLE FOR FUNCTION FPVS.
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN 90
-!! MACHINE: IBM SP
-!!
-!!
-!#######################################################################
-!-- Lookup tables for the saturation vapor pressure w/r/t water & ice --
-!#######################################################################
-!
+!> @brief gpvs() computes saturation vapor pressure table.
+!>
+!> Compute saturation vapor pressure table as a function of
+!> temperature for the table lookup function FPVS.
+!> Exact saturation vapor pressures are calculated in subprogram FPVSX.
+!> The current implementation computes a table with a length
+!> of 7501 for temperatures ranging from 180.0 to 330.0 Kelvin.
+!>
+!> @param[out] pvu real (km) potential vorticity (10**-6*K*m**2/kg/s).
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1982-12-30 | N Phillips | Initial
+!> 1991-05-07 | Mark Iredell | Made into inlinable function
+!> 1994-12-30 | Mark Iredell | Expand table
+!> 1996-02-19 | Hong | Ice effect
+!>
+!> @note Lookup tables for the saturation vapor pressure w/r/t water & ice.
+!> @author N Phillips W/NP2 @date 1982-12-30
SUBROUTINE GPVS
! ******************************************************************
@@ -65,40 +53,28 @@ SUBROUTINE GPVS
!-----------------------------------------------------------------------
FUNCTION FPVS(T)
!-----------------------------------------------------------------------
-!$$$ SUBPROGRAM DOCUMENTATION BLOCK
-! . . .
-! SUBPROGRAM: FPVS COMPUTE SATURATION VAPOR PRESSURE
-! AUTHOR: N PHILLIPS W/NP2 DATE: 30 DEC 82
-!
-! ABSTRACT: COMPUTE SATURATION VAPOR PRESSURE FROM THE TEMPERATURE.
-! A LINEAR INTERPOLATION IS DONE BETWEEN VALUES IN A LOOKUP TABLE
-! COMPUTED IN GPVS. SEE DOCUMENTATION FOR FPVSX FOR DETAILS.
-! INPUT VALUES OUTSIDE TABLE RANGE ARE RESET TO TABLE EXTREMA.
-! THE INTERPOLATION ACCURACY IS ALMOST 6 DECIMAL PLACES.
-! ON THE CRAY, FPVS IS ABOUT 4 TIMES FASTER THAN EXACT CALCULATION.
-! THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE.
-!
-! PROGRAM HISTORY LOG:
-! 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION
-! 94-12-30 IREDELL EXPAND TABLE
-! 96-02-19 HONG ICE EFFECT
-!
-! USAGE: PVS=FPVS(T)
-!
-! INPUT ARGUMENT LIST:
-! T - REAL TEMPERATURE IN KELVIN
-!
-! OUTPUT ARGUMENT LIST:
-! FPVS - REAL SATURATION VAPOR PRESSURE IN KILOPASCALS (CB)
-!
-! COMMON BLOCKS:
-! COMPVS - SCALING PARAMETERS AND TABLE COMPUTED IN GPVS.
-!
-! ATTRIBUTES:
-! LANGUAGE: FORTRAN 90
-! MACHINE: IBM SP
-!
-!$$$
+!> fpvs() computes saturation vapor pressure.
+!>
+!> Compute saturation vapor pressure from the temperature.
+!> A linear interpolation is done between values in a lookup table
+!> computed in GPVS. See documentation for FPVSX for details.
+!> Input values outside table range are reset to table extrema.
+!> The interpolation accuracy is almost 6 decimal places.
+!> On the CRAY, FPVS is about 4 times faster than exact calculation.
+!> This function should be expanded inline in the calling routine.
+!>
+!> @param[in] T real temperature in Kelvin.
+!> @param[out] FPVS real saturation vapor pressure in kilopascals (CB).
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1982-12-30 | N Phillips | Initial
+!> 1991-05-07 | Mark Iredell | Made into inlinable function
+!> 1994-12-30 | Mark Iredell | Expand table
+!> 1996-02-19 | Hong | Ice effect
+!>
+!> @author N Phillips W/NP2 @date 1982-12-30
!-----------------------------------------------------------------------
use svptbl_mod, only : NX,C1XPVS,C2XPVS,TBPVS
!
@@ -144,41 +120,33 @@ FUNCTION FPVS0(T,NX,C1XPVS0,C2XPVS0,TBPVS0)
!-----------------------------------------------------------------------
FUNCTION FPVSX(T)
!-----------------------------------------------------------------------
-!$$$ SUBPROGRAM DOCUMENTATION BLOCK
-! . . .
-! SUBPROGRAM: FPVSX COMPUTE SATURATION VAPOR PRESSURE
-! AUTHOR: N PHILLIPS W/NP2 DATE: 30 DEC 82
-!
-! ABSTRACT: EXACTLY COMPUTE SATURATION VAPOR PRESSURE FROM TEMPERATURE.
-! THE WATER MODEL ASSUMES A PERFECT GAS, CONSTANT SPECIFIC HEATS
-! FOR GAS AND LIQUID, AND NEGLECTS THE VOLUME OF THE LIQUID.
-! THE MODEL DOES ACCOUNT FOR THE VARIATION OF THE LATENT HEAT
-! OF CONDENSATION WITH TEMPERATURE. THE ICE OPTION IS NOT INCLUDED.
-! THE CLAUSIUS-CLAPEYRON EQUATION IS INTEGRATED FROM THE TRIPLE POINT
-! TO GET THE FORMULA
-! PVS=PSATK*(TR**XA)*EXP(XB*(1.-TR))
-! WHERE TR IS TTP/T AND OTHER VALUES ARE PHYSICAL CONSTANTS
-! THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE.
-!
-! PROGRAM HISTORY LOG:
-! 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION
-! 94-12-30 IREDELL EXACT COMPUTATION
-! 96-02-19 HONG ICE EFFECT
-!
-! USAGE: PVS=FPVSX(T)
-! REFERENCE: EMANUEL(1994),116-117
-!
-! INPUT ARGUMENT LIST:
-! T - REAL TEMPERATURE IN KELVIN
-!
-! OUTPUT ARGUMENT LIST:
-! FPVSX - REAL SATURATION VAPOR PRESSURE IN KILOPASCALS (CB)
-!
-! ATTRIBUTES:
-! LANGUAGE: FORTRAN 90
-! MACHINE: IBM SP
-!
-!$$$
+!> fpvsx() computes saturation vapor pressure.
+!>
+!> Exactly compute saturation vapor pressure from temperature.
+!> The water model assumes a perfect gas, constant specific heats
+!> for gas and liquid, and neglects the volume of the liquid.
+!> The model does account for the variation of the latent heat
+!> of condensation with temperature. The ice option is not included.
+!> The Clausius-Clapeyron equation is integrated from the triple point
+!> To get the formula
+!> @code
+!> PVS=PSATK*(TR**XA)*exp(XB*(1.-TR))
+!> @endcode
+!> where TR is TTP/T and other values are physical constants
+!> This function should be expanded inline in the calling routine.
+!>
+!> @param[in] T real temperature in Kelvin.
+!> @param[out] FPVSX real saturation vapor pressure in kilopascals (CB).
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1982-12-30 | N Phillips | Initial
+!> 1991-05-07 | Mark Iredell | Made into inlinable function
+!> 1994-12-30 | Mark Iredell | Exact computation
+!> 1996-02-19 | Hong | Ice effect
+!>
+!> @author N Phillips W/NP2 @date 1982-12-30
!-----------------------------------------------------------------------
implicit none
!
diff --git a/sorc/ncep_post.fd/ICAOHEIGHT.f b/sorc/ncep_post.fd/ICAOHEIGHT.f
index f21dc427b..139f99307 100644
--- a/sorc/ncep_post.fd/ICAOHEIGHT.f
+++ b/sorc/ncep_post.fd/ICAOHEIGHT.f
@@ -18,15 +18,15 @@ SUBROUTINE ICAOHEIGHT(MAXWP, & !input
! Language: Fortran 90
! Software Standards: UMDP3 v6
-use ctlblk_mod, only: jsta, jend, spval, im
+use ctlblk_mod, only: jsta, jend, spval, im, ista, iend
use physcons_post, only: con_g, con_rd
IMPLICIT None
! Subroutine Arguments:
!REAL, INTENT(IN) :: SPVAL
-REAL, INTENT(IN) :: MAXWP(IM,jsta:jend) !P field for conversion
+REAL, INTENT(IN) :: MAXWP(ista:iend,jsta:jend) !P field for conversion
-REAL, INTENT(INOUT) :: MAXWICAOZ(IM,jsta:jend) !ICAO height in m
+REAL, INTENT(INOUT) :: MAXWICAOZ(ista:iend,jsta:jend) !ICAO height in m
!INTEGER, INTENT(INOUT) :: ErrorStatus
! Local Constants:
@@ -62,7 +62,7 @@ SUBROUTINE ICAOHEIGHT(MAXWP, & !input
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
pressure = MAXWP(i,j)
IF ( (pressure <= 1000.) .AND. (pressure >= 0.) ) THEN
pressure = 1000.
diff --git a/sorc/ncep_post.fd/INITPOST.F b/sorc/ncep_post.fd/INITPOST.F
index 87cd31af5..5e74564ab 100644
--- a/sorc/ncep_post.fd/INITPOST.F
+++ b/sorc/ncep_post.fd/INITPOST.F
@@ -1,46 +1,26 @@
!> @file
-!
-!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN
-!! PRGRMMR: RUSS TREADON ORG: W/NP2 DATE: 93-11-10
-!!
-!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND
-!! VARIABLES AT THE START OF AN ETA MODEL OR POST
-!! PROCESSOR RUN.
-!!
-!! THIS ROUTINE ASSUMES THAT INTEGERS AND REALS ARE THE SAME SIZE
-!!
-!! PROGRAM HISTORY LOG:
-!! 93-11-10 RUSS TREADON - ADDED DOCBLOC
-!! 98-05-29 BLACK - CONVERSION OF POST CODE FROM 1-D TO 2-D
-!! 99-01 20 TUCCILLO - MPI VERSION
-!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT
-!! 02-06-19 MIKE BALDWIN - WRF VERSION
-!! 02-08-15 H CHUANG - UNIT CORRECTION AND GENERALIZE PROJECTION OPTIONS
-!! 21-03-11 Bo Cui - change local arrays to dimension (im,jsta:jend)
-!!
-!! USAGE: CALL INIT
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! NONE
-!! LIBRARY:
-!! COMMON - CTLBLK
-!! LOOKUP
-!! SOILDEPTH
-!!
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
+!> @brief initpost() initializes post for run.
+!>
+!> @author Russ Treadon W/NP2 @date 1993-11-10
+
+!> This routine initializes constants and
+!> variables at the start of an ETA model or post
+!> processor run.
+!>
+!> This routine assumes that integers and reals are the same size.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1993-11-10 | Russ Treadon | Initial. Added DOCBLOC
+!> 1998-05-29 | T Black | Conversion from 1-D to 2-D
+!> 1999-01-20 | Jim Tuccillo | MPI Version
+!> 2001-10-25 | H CHuang | Modified to process hybrid model output
+!> 2002-06-19 | Mike Baldwin | WRF Version
+!> 2002-08-15 | H CHuang | Unit correction and generalize projection options
+!> 2021-03-11 | Bo Cui | Change local arrays to dimension (im,jsta:jend)
+!>
+!> @author Russ Treadon W/NP2 @date 1993-11-10
SUBROUTINE INITPOST
use vrbls4d, only: dust, smoke
diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f b/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f
deleted file mode 100644
index 2f04cfb7e..000000000
--- a/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f
+++ /dev/null
@@ -1,3264 +0,0 @@
-!> @file
-! . . .
-!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN
-!! PRGRMMR: Hui-Ya Chuang DATE: 2007-03-01
-!!
-!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND
-!! VARIABLES AT THE START OF GFS MODEL OR POST
-!! PROCESSOR RUN.
-!!
-!! REVISION HISTORY
-!! 2011-02-07 Jun Wang add grib2 option
-!! 2011-12-14 Sarah Lu add aer option
-!! 2012-01-07 Sarah Lu compute air density
-!! 2012-12-22 Sarah Lu add aerosol zerout option
-!! 2015-03-16 S. Moorthi adding gocart_on option
-!! 2015-03-18 S. Moorthi Optimization including threading
-!! 2015-08-17 S. Moorthi Add TKE for NEMS/GSM
-!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend)
-!!
-!! USAGE: CALL INIT
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! NONE
-!! LIBRARY:
-!! COMMON - CTLBLK
-!! LOOKUP
-!! SOILDEPTH
-!!
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
- SUBROUTINE INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D, &
- iostatusAER,nfile,ffile,rfile)
-! SUBROUTINE INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,nfile,ffile)
-
-
- use vrbls4d, only: dust, SALT, SUSO, SOOT, WASO
- use vrbls3d, only: t, q, uh, vh, pmid, pint, alpint, dpres, zint, zmid, o3, &
- qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, &
- tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, &
- o3vdiff, o3prod, o3tndy, mwpv, unknown, vdiffzacce, zgdrag,cnvctummixing, &
- vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, &
- cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp
- use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, &
- cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, &
- tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, radot, sigt4, &
- cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, &
- islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, &
- bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, &
- rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, &
- snopcx, sfcux, sfcvx, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, &
- smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, &
- uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, &
- ptoph, pboth, pblcfr, ttoph, runoff, maxtshltr, mintshltr, maxrhshltr, &
- minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, &
- cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa, &
- u10h,v10h
- use soil, only: sldpth, sh2o, smc, stc
- use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice
-! use kinds, only: i_llong
- use nemsio_module, only: nemsio_gfile, nemsio_getfilehead, nemsio_getheadvar, nemsio_close
- use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, &
- eps => con_eps, epsm1 => con_epsm1
- use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa
- use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, &
- ttblq, rdpq, rdtheq, stheq, the0q, the0
- use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, &
- ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, &
- jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,&
- ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, &
- jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, &
- nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp
- use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, &
- dxval, dyval, truelat2, truelat1, psmapf, cenlat
- use upp_physics, only: fpvsnew
-! use wrf_io_flags_mod, only: ! Do we need this?
-!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- implicit none
-!
- type(nemsio_gfile),intent(inout) :: nfile,ffile,rfile
-!
-! INCLUDE/SET PARAMETERS.
-!
- INCLUDE "mpif.h"
-
-! integer,parameter:: MAXPTS=1000000 ! max im*jm points
-!
-! real,parameter:: con_g =9.80665e+0! gravity
-! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O
-! real,parameter:: con_rd =2.8705e+2 ! gas constant air
-! real,parameter:: con_fvirt =con_rv/con_rd-1.
-! real,parameter:: con_eps =con_rd/con_rv
-! real,parameter:: con_epsm1 =con_rd/con_rv-1
-!
-! This version of INITPOST shows how to initialize, open, read from, and
-! close a NetCDF dataset. In order to change it to read an internal (binary)
-! dataset, do a global replacement of _ncd_ with _int_.
-
- real, parameter :: gravi = 1.0/grav
- integer,intent(in) :: NREC,iostatusFlux,iostatusD3D,iostatusAER
- character(len=20) :: VarName, VcoordName
- integer :: Status
- character startdate*19,SysDepInfo*80,cgar*1
- character startdate2(19)*4
-!
-! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK
-! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE.
-!
-! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE
-! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE.
- LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL
- logical, parameter :: debugprint = .false., zerout = .false.
-! logical, parameter :: debugprint = .true., zerout = .false.
- CHARACTER*32 LABEL
- CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC
- CHARACTER*4 RESTHR
- CHARACTER FNAME*255,ENVAR*50
- INTEGER IDATE(8),JDATE(8),JPDS(200),JGDS(200),KPDS(200),KGDS(200),IGDS(18)
-! LOGICAL*1 LB(IM,JM)
-!
-! INCLUDE COMMON BLOCKS.
-!
-! DECLARE VARIABLES.
-!
-! REAL fhour
- integer nfhour ! forecast hour from nems io file
- REAL RINC(5)
-
- REAL DUMMY(IM,JM), DUMMY2(IM,JM)
- real, allocatable :: fi(:,:,:)
-!jw
- integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, &
- I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, &
- impf,jmpf,nframed2,iunitd3d,ierr,idum,iret
- real TSTART,TLMH,TSPH,ES,FACT,soilayert,soilayerb,zhour,dum, &
- tvll,pmll,tv
-
- character*8, allocatable :: recname(:)
- character*16,allocatable :: reclevtyp(:)
- integer, allocatable :: reclev(:)
- real, allocatable :: glat1d(:), glon1d(:), qstl(:)
- real, allocatable :: wrk1(:,:), wrk2(:,:)
- real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), &
- qs2d(:,:), cw2d(:,:), cfr2d(:,:)
- real(kind=4),allocatable :: vcoord4(:,:,:)
- real, dimension(lm+1) :: ak5, bk5
- real*8, allocatable :: pm2d(:,:), pi2d(:,:)
-
- real buf(im,jsta_2l:jend_2u)
-
-! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) &
-! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u)
-
- real LAT, isa, jsa
-! REAL, PARAMETER :: QMIN = 1.E-15
-
-! DATA BLANK/' '/
-!
-!***********************************************************************
-! START INIT HERE.
-!
- WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NEMS'
- WRITE(6,*)'me=',me,'LMV=',size(LMV,1),size(LMV,2),'LMH=', &
- size(LMH,1),size(LMH,2),'jsta_2l=',jsta_2l,'jend_2u=', &
- jend_2u,'im=',im
-!
- isa = im / 2
- jsa = (jsta+jend) / 2
-
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- buf(i,j) = spval
- enddo
- enddo
-!
-! STEP 1. READ MODEL OUTPUT FILE
-!
-!
-!***
-!
-! LMH and LMV always = LM for sigma-type vert coord
-
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i = 1, im
- LMV(i,j) = lm
- LMH(i,j) = lm
- end do
- end do
-
-! HTM VTM all 1 for sigma-type vert coord
-
-!$omp parallel do private(i,j,l)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- HTM (i,j,l) = 1.0
- VTM (i,j,l) = 1.0
- end do
- end do
- end do
-!
-! how do I get the filename?
-! fileName = '/ptmp/wx20mb/wrfout_01_030500'
-! DateStr = '2002-03-05_18:00:00'
-! how do I get the filename?
-! call ext_int_ioinit(SysDepInfo,Status)
-! print*,'called ioinit', Status
-! call ext_int_open_for_read( trim(fileName), 0, 0, " ",
-! & DataHandle, Status)
-! print*,'called open for read', Status
-! if ( Status /= 0 ) then
-! print*,'error opening ',fileName, ' Status = ', Status ; stop
-! endif
-! get date/time info
-! this routine will get the next time from the file, not using it
-! print *,'DateStr before calling ext_int_get_next_time=',DateStr
-! call ext_int_get_next_time(DataHandle, DateStr, Status)
-! print *,'DateStri,Status,DataHandle = ',DateStr,Status,DataHandle
-
-! The end j row is going to be jend_2u for all variables except for V.
-
- JS = JSTA_2L
- JE = JEND_2U
-
-! get start date
- if (me == 0)then
- print*,'nrec=',nrec
- allocate(recname(nrec),reclevtyp(nrec),reclev(nrec))
- allocate(glat1d(im*jm),glon1d(im*jm))
- allocate(vcoord4(lm+1,3,2))
- call nemsio_getfilehead(nfile,iret=iret &
- ,idate=idate(1:7),nfhour=nfhour,recname=recname &
- ,reclevtyp=reclevtyp,reclev=reclev,lat=glat1d &
- ,lon=glon1d,nframe=nframe,vcoord=vcoord4)
- if(iret/=0)print*,'error getting idate,nfhour'
- print *,'latstar1=',glat1d(1),glat1d(im*jm)
-! print *,'printing an inventory of GFS nemsio file'
-! do i=1,nrec
-! print *,'recname=',(trim(recname(i)))
-! print *,'reclevtyp=',(trim(reclevtyp(i)))
-! print *,'reclev=',(reclev(i))
-! end do
-! deallocate (recname,reclevtyp,reclev)
-
-! call nemsio_getfilehead(ffile,nrec=idum)
-! print*,'nrec for flux file = ',idum
-! allocate(recname(idum),reclevtyp(idum),reclev(idum))
-! call nemsio_getfilehead(ffile,iret=iret, &
-! recname=recname,reclevtyp=reclevtyp,reclev=reclev)
-! do i=1,idum
-! print *,'recname=',(trim(recname(i)))
-! print *,'reclevtyp=',(trim(reclevtyp(i)))
-! print *,'reclev=',(reclev(i))
-! end do
-
-!$omp parallel do private(i,j)
- do j=1,jm
- do i=1,im
- dummy(i,j) = glat1d((j-1)*im+i)
- dummy2(i,j) = glon1d((j-1)*im+i)
- end do
- end do
-!
- if (hyb_sigp) then
- do l=1,lm+1
- ak5(l) = vcoord4(l,1,1)
- bk5(l) = vcoord4(l,2,1)
- enddo
- endif
-!
- deallocate(recname,reclevtyp,reclev,glat1d,glon1d,vcoord4)
-! can't get idate and fhour, specify them for now
-! idate(4)=2006
-! idate(2)=9
-! idate(3)=16
-! idate(1)=0
-! fhour=6.0
- print*,'idate before broadcast = ',(idate(i),i=1,7)
- end if
- call mpi_bcast(idate(1), 7, MPI_INTEGER, 0, mpi_comm_comp, iret)
- call mpi_bcast(nfhour, 1, MPI_INTEGER, 0, mpi_comm_comp, iret)
- call mpi_bcast(nframe, 1, MPI_INTEGER, 0, mpi_comm_comp, iret)
- print*,'idate after broadcast = ',(idate(i),i=1,4)
- print*,'nfhour = ',nfhour
-
- if (hyb_sigp) then
- call mpi_bcast(ak5, lm+1, MPI_REAL, 0, mpi_comm_comp, iret)
- call mpi_bcast(bk5, lm+1, MPI_REAL, 0, mpi_comm_comp, iret)
- endif
- if (me == 0) print *,' ak5=',ak5
- if (me == 0) print *,' bk5=',bk5
-
-! sample print point
- ii = im/2
- jj = jm/2
- call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real &
- ,gdlat(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,ierr)
- call mpi_scatterv(dummy2(1,1),icnt,idsp,mpi_real &
- ,gdlon(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,ierr)
-
- print *,'before call EXCH,mype=',me,'max(gdlat)=',maxval(gdlat), &
- 'max(gdlon)=', maxval(gdlon)
- CALL EXCH(gdlat(1,JSTA_2L))
- print *,'after call EXCH,mype=',me
-
-!$omp parallel do private(i,j)
- do j = jsta, jend_m
- do i = 1, im-1
- DX (i,j) = ERAD*COS(GDLAT(I,J)*DTR) *(GDLON(I+1,J)-GDLON(I,J))*DTR
- DY (i,j) = ERAD*(GDLAT(I,J)-GDLAT(I,J+1))*DTR ! like A*DPH
-! F(I,J)=1.454441e-4*sin(gdlat(i,j)*DTR) ! 2*omeg*sin(phi)
-! if (i == ii .and. j == jj) print*,'sample LATLON, DY, DY=' &
-! ,i,j,GDLAT(I,J),GDLON(I,J),DX(I,J),DY(I,J)
- end do
- end do
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- F(I,J) = 1.454441e-4*sin(gdlat(i,j)*DTR) ! 2*omeg*sin(phi)
- end do
- end do
-
- impf = im
- jmpf = jm
- print*,'impf,jmpf,nframe= ',impf,jmpf,nframe
-
-!MEB not sure how to get these
- ! waiting to read in lat lon from GFS soon
-! varname='GLAT'
-! call retrieve_index(index,VarName,varname_all,nrecs,iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! GDLAT=SPVAL
-! else
-! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im
-! this_length=im*(jend_2u-jsta_2l+1)
-! call mpi_file_read_at(iunit,this_offset
-! + ,buf,this_length,mpi_real4
-! + , mpi_status_ignore, ierr)
-! if (ierr /= 0) then
-! print*,"Error reading ", VarName,"Assigned missing values"
-! GDLAT=SPVAL
-! else
-! do j = jsta_2l, jend_2u
-! do i = 1, im
-! F(I,J)=1.454441e-4*sin(buf(I,J)) ! 2*omeg*sin(phi)
-! GDLAT(I,J)=buf(I,J)*RTD
-
-! enddo
-! enddo
-! end if
-! end if
-
-! varname='GLON'
-! call retrieve_index(index,VarName,varname_all,nrecs,iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! GDLON=SPVAL
-! else
-! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im
-! this_length=im*(jend_2u-jsta_2l+1)
-! call mpi_file_read_at(iunit,this_offset
-! + ,buf,this_length,mpi_real4
-! + , mpi_status_ignore, ierr)
-! if (ierr /= 0) then
-! print*,"Error reading ", VarName,"Assigned missing values"
-! GDLON=SPVAL
-! else
-! do j = jsta_2l, jend_2u
-! do i = 1, im
-! GDLON(I,J)=buf(I,J)*RTD
-! if(i == 409.and.j == 835)print*,'GDLAT GDLON in INITPOST='
-! + ,i,j,GDLAT(I,J),GDLON(I,J)
-! enddo
-! enddo
-! end if
-! end if
-
-! if(jsta<=594.and.jend>=594)print*,'gdlon(120,594)= ',
-! + gdlon(120,594)
-
-
-! iyear=idate(4)+2000 ! older gfsio only has 2 digit year
- iyear = idate(1)
- imn = idate(2) ! ask Jun
- iday = idate(3) ! ask Jun
- ihrst = idate(4)
- imin = idate(5)
- jdate = 0
- idate = 0
-!
-! read(startdate,15)iyear,imn,iday,ihrst,imin
- 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2)
- print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin
- print*,'processing yr mo day hr min=' &
- ,idat(3),idat(1),idat(2),idat(4),idat(5)
-!
- idate(1) = iyear
- idate(2) = imn
- idate(3) = iday
- idate(5) = ihrst
- idate(6) = imin
- SDAT(1) = imn
- SDAT(2) = iday
- SDAT(3) = iyear
- jdate(1) = idat(3)
- jdate(2) = idat(1)
- jdate(3) = idat(2)
- jdate(5) = idat(4)
- jdate(6) = idat(5)
-!
- print *,' idate=',idate
- print *,' jdate=',jdate
-! CALL W3DIFDAT(JDATE,IDATE,2,RINC)
-! ifhr=nint(rinc(2))
-!
- CALL W3DIFDAT(JDATE,IDATE,0,RINC)
-!
- print *,' rinc=',rinc
- ifhr = nint(rinc(2)+rinc(1)*24.)
- print *,' ifhr=',ifhr
- ifmin = nint(rinc(3))
-! if(ifhr /= nint(fhour))print*,'find wrong Grib file';stop
- print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,fileName
-
-! GFS has the same accumulation bucket for precipitation and fluxes and it is written to header
-! the header has the start hour information so post uses it to recontruct bucket
- if(me==0)then
- call nemsio_getheadvar(ffile,'zhour',zhour,iret=iret)
- if(iret==0)then
- tprec = 1.0*ifhr-zhour
- tclod = tprec
- trdlw = tprec
- trdsw = tprec
- tsrfc = tprec
- tmaxmin = tprec
- td3d = tprec
- print*,'tprec from flux file header= ',tprec
- else
- print*,'Error reading accumulation bucket from flux file', &
- 'header - will try to read from env variable FHZER'
- CALL GETENV('FHZER',ENVAR)
- read(ENVAR, '(I2)')idum
- tprec = idum*1.0
- tclod = tprec
- trdlw = tprec
- trdsw = tprec
- tsrfc = tprec
- tmaxmin = tprec
- td3d = tprec
- print*,'TPREC from FHZER= ',tprec
- end if
- end if
-
- call mpi_bcast(tprec, 1,MPI_REAL,0,mpi_comm_comp,iret)
- call mpi_bcast(tclod, 1,MPI_REAL,0,mpi_comm_comp,iret)
- call mpi_bcast(trdlw, 1,MPI_REAL,0,mpi_comm_comp,iret)
- call mpi_bcast(trdsw, 1,MPI_REAL,0,mpi_comm_comp,iret)
- call mpi_bcast(tsrfc, 1,MPI_REAL,0,mpi_comm_comp,iret)
- call mpi_bcast(tmaxmin,1,MPI_REAL,0,mpi_comm_comp,iret)
- call mpi_bcast(td3d, 1,MPI_REAL,0,mpi_comm_comp,iret)
-
-! Getting tstart
- tstart=0.
-! VarName='TSTART'
-! call retrieve_index(index,VarName,varname_all,nrecs,iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file"
-! else
-! call mpi_file_read_at(iunit,file_offset(index)+5*4
-! + ,garb,1,mpi_real4
-! + , mpi_status_ignore, ierr)
-! if (ierr /= 0) then
-! print*,"Error reading ", VarName," using MPIIO"
-! else
-! print*,VarName, ' from MPIIO READ= ',garb
-! tstart=garb
-! end if
-! end if
- print*,'tstart= ',tstart
-
-! Getiing restart
-
- RESTRT=.TRUE. ! set RESTRT as default
-! call ext_int_get_dom_ti_integer(DataHandle,'RESTARTBIN',itmp
-! + ,1,ioutcount,istatus)
-
-! IF(itmp < 1)THEN
-! RESTRT=.FALSE.
-! ELSE
-! RESTRT=.TRUE.
-! END IF
-
-! print*,'status for getting RESTARTBIN= ',istatus
-
-! print*,'Is this a restrt run? ',RESTRT
-
- IF(tstart > 1.0E-2)THEN
- ifhr = ifhr+NINT(tstart)
- rinc = 0
- idate = 0
- rinc(2) = -1.0*ifhr
- call w3movdat(rinc,jdate,idate)
- SDAT(1) = idate(2)
- SDAT(2) = idate(3)
- SDAT(3) = idate(1)
- IHRST = idate(5)
- print*,'new forecast hours for restrt run= ',ifhr
- print*,'new start yr mo day hr min =',sdat(3),sdat(1) &
- ,sdat(2),ihrst,imin
- END IF
-
- imp_physics = 99 !set GFS mp physics to 99 for Zhao scheme
- print*,'MP_PHYSICS= ',imp_physics
-
-! Initializes constants for Ferrier microphysics
- if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then
- CALL MICROINIT(imp_physics)
- end if
-
-! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD
- VarName='IVEGSRC'
- if(me == 0)then
- call nemsio_getheadvar(nfile,trim(VarName),IVEGSRC,iret)
- if (iret /= 0) then
- print*,VarName,' not found in file-Assigned 2 for UMD as default'
- IVEGSRC=1
- end if
- end if
- call mpi_bcast(IVEGSRC,1,MPI_INTEGER,0,mpi_comm_comp,iret)
- print*,'IVEGSRC= ',IVEGSRC
-
-! set novegtype based on vegetation classification
- if(ivegsrc==2)then
- novegtype=13
- else if(ivegsrc==1)then
- novegtype=20
- else if(ivegsrc==0)then
- novegtype=24
- end if
- print*,'novegtype= ',novegtype
-
- VarName='CU_PHYSICS'
- if(me == 0)then
- call nemsio_getheadvar(nfile,trim(VarName),iCU_PHYSICS,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned 4 for SAS as default"
- iCU_PHYSICS=4
- end if
- end if
- call mpi_bcast(iCU_PHYSICS,1,MPI_INTEGER,0,mpi_comm_comp,iret)
- if (me == 0) print*,'CU_PHYSICS= ',iCU_PHYSICS
-! waiting to retrieve lat lon infor from raw GFS output
-! VarName='DX'
-
-! VarName='DY'
-
-! GFS does not need DT to compute accumulated fields, set it to one
-! VarName='DT'
- DT=1
-! GFS does not need truelat
-! VarName='TRUELAT1'
-
-! VarName='TRUELAT2'
-
-! Specigy maptype=4 for Gaussian grid
-! maptype=4
-! write(6,*) 'maptype is ', maptype
-! HBM2 is most likely not in Grib message, set them to ones
- HBM2=1.0
-
-! try to get kgds from flux grib file and then convert to igds that is used by GRIBIT.f
-! flux files are now nemsio files so comment the following lines out
-! if(me == 0)then
-! jpds=-1.0
-! jgds=-1.0
-! igds=0
-! call getgb(iunit,0,im_jm,0,jpds,jgds,kf &
-! ,k,kpds,kgds,lb,dummy,ierr)
-! if(ierr == 0)then
-! call R63W72(KPDS,KGDS,JPDS,IGDS(1:18))
-! print*,'in INITPOST_GFS,IGDS for GFS= ',(IGDS(I),I=1,18)
-! end if
-! end if
-! call mpi_bcast(igds(1),18,MPI_INTEGER,0,mpi_comm_comp,iret)
-! print*,'IGDS for GFS= ',(IGDS(I),I=1,18)
-
-! Specigy grid type
-! if(iostatusFlux==0)then
- if(IGDS(4)/=0)then
- maptype=IGDS(3)
- else if((im/2+1)==jm)then
- maptype=0 !latlon grid
- else
- maptype=4 ! default gaussian grid
- end if
- gridtype='A'
-
- if (me == 0) write(6,*) 'maptype and gridtype is ', maptype,gridtype
-
-! start retrieving data using gfsio, first land/sea mask
-
-! VarName='land'
-! VcoordName='sfc'
-! l=1
-
-! if(me == 0)then
-! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName)
-! + ,l,dummy,iret=iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! dummy=spval
-! else
-!
-! do j = 1, jm
-! do i = 1, im
-! dummy(I,J)=1.0 - dummy(I,J) ! convert Grib message to 2D
-! if (j == jm/2 .and. mod(i,10) == 0)
-! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j)
-!
-! enddo
-! enddo
-! end if
-! end if
-!
-! call mpi_scatterv(dummy,icnt,idsp,mpi_real
-! + ,sm(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret)
-! if (iret /= 0)print*,'Error scattering array';stop
-
- VcoordName='sfc' ! surface fileds
- l=1
-
-! start retrieving data using getgb, first land/sea mask
- VarName='land'
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,impf,jmpf,nframe,sm)
-
-! where(sm /= spval)sm=1.0-sm ! convert to sea mask
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',sm(isa,jsa)
-
-
-! sea ice mask using getgb
-
- VarName='icec'
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,sice)
-
-! if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa)
-
-! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea mask=0
-! GFS flux files have land points with non-zero sea ice, per Iredell, these
-! points have sea ice changed to zero, i.e., trust land mask more than sea ice
-! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0
- enddo
- enddo
-
-! Terrain height * G using nemsio
- VarName='hgt'
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,fis)
-
-! where(fis /= spval)fis=fis*grav
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (fis(i,j) /= spval) then
- zint(i,j,lp1) = fis(i,j)
- fis(i,j) = fis(i,j) * grav
-
- endif
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',fis(isa,jsa)
-
-! Surface pressure using nemsio
- VarName='pres'
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,pint(1,jsta_2l,lp1))
-
-! if(debugprint)print*,'sample surface pressure = ',pint(isa,jsa,lp1
-
-!
-! vertical loop for Layer 3d fields
-! --------------------------------
- VcoordName = 'mid layer'
-
- do l=1,lm
- ll=lm-l+1
-
-! model level T
- print*,'start retrieving GFS T using nemsio'
- VarName='tmp'
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,t(1,jsta_2l,ll))
-
-! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,t(isa,jsa,ll)
-
-! model level q
- VarName='spfh'
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,q(1,jsta_2l,ll))
-! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,q(isa,jsa,ll)
-
-! i model level u
- VarName='ugrd'
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,uh(1,jsta_2l,ll))
-! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,uh(isa,jsa,ll)
-
-! model level v
- VarName='vgrd'
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,vh(1,jsta_2l,ll))
-! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,vh(isa,jsa,ll)
-
-! model level pressure
- if (.not. hyb_sigp) then
- VarName='pres'
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,pmid(1,jsta_2l,ll))
-! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,pmid(isa,jsa,ll)
-
-! GFS is on A grid and does not need PMIDV
-
-! dp
- VarName='dpres'
-! write(0,*)' bef getnemsandscatter ll=',ll,' l=',l,VarName
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,dpres(1,jsta_2l,ll))
-! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,pmid(isa,jsa,ll)
- endif
-! ozone mixing ratio
- VarName='o3mr'
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,o3(1,jsta_2l,ll))
-
-! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,o3(isa,jsa,ll)
-! write(1000+me,*)'sample ',ll,VarName,' = ',ll,o3(isa,jsa,ll)
-
-! cloud water and ice mixing ratio for zhao scheme
-! need to look up old eta post to derive cloud water/ice from cwm
-! Zhao scheme does not produce suspended rain and snow
-
-!$omp parallel do private(i,j)
- do j = jsta, jend
- do i=1,im
- qqw(i,j,ll) = 0.
- qqr(i,j,ll) = 0.
- qqs(i,j,ll) = 0.
- qqi(i,j,ll) = 0.
- enddo
- enddo
-
- VarName='clwmr'
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,cwm(1,jsta_2l,ll))
-! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,cwm(isa,jsa,ll)
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if(t(i,j,ll) < (TFRZ-15.) )then ! dividing cloud water from ice
- qqi(i,j,ll) = cwm(i,j,ll)
- else
- qqw(i,j,ll) = cwm(i,j,ll)
- end if
-! if (j == jm/2 .and. mod(i,50) == 0)
-! + print*,'sample ',trim(VarName), ' after scatter= '
-! + ,i,j,ll,cwm(i,j,ll)
- end do
- end do
-! if (iret /= 0)print*,'Error scattering array';stop
-
-! pressure vertical velocity
- VarName='vvel'
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,omga(1,jsta_2l,ll))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,omga(isa,jsa,ll)
-
-! With SHOC NEMS/GSM does output TKE now
- VarName='tke'
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,q2(1,jsta_2l,ll))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,q2(isa,jsa,ll)
-
-
- end do ! do loop for l
-
-! construct interface pressure from model top (which is zero) and dp from top down PDTOP
-! pdtop = spval
- pt = 0.
-! pd = spval ! GFS does not output PD
-
- ii = im/2
- jj = (jsta+jend)/2
-
-!!!!! COMPUTE Z, GFS integrates Z on mid-layer instead
-!!! use GFS contants to see if height becomes more aggreable to GFS pressure grib file
- if (hyb_sigp) then
- do l=lm,1,-1
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- pint(i,j,l) = ak5(lm+2-l) + bk5(lm+2-l)*pint(i,j,lp1)
- pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) ! for now - Moorthi
- enddo
- enddo
- if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l)
- enddo
- else
- do l=2,lm
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1)
- enddo
- enddo
- if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l)
- end do
- endif
-
- allocate(wrk1(im,jsta:jend),wrk2(im,jsta:jend))
- allocate(fi(im,jsta:jend,2))
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- pd(i,j) = spval ! GFS does not output PD
- pint(i,j,1) = PT
- alpint(i,j,lp1) = log(pint(i,j,lp1))
- wrk1(i,j) = log(PMID(I,J,LM))
- wrk2(i,j) = T(I,J,LM)*(Q(I,J,LM)*fv+1.0)
- FI(I,J,1) = FIS(I,J) &
- + wrk2(i,j)*rgas*(ALPINT(I,J,Lp1)-wrk1(i,j))
- ZMID(I,J,LM) = FI(I,J,1) * gravi
- end do
- end do
-
- print *,' Tprof=',t(ii,jj,:)
- print *,' Qprof=',q(ii,jj,:)
-
-! SECOND, INTEGRATE HEIGHT HYDROSTATICLY, GFS integrate height on mid-layer
-
- DO L=LM,2,-1 ! omit computing model top height because it's infinity
- ll = l - 1
-! write(0,*)' me=',me,'ll=',ll,' gravi=',gravi,rgas,' fv=',fv
-!$omp parallel do private(i,j,tvll,pmll,fact)
- do j = jsta, jend
-! write(0,*)' j=',j,' me=',me
- do i = 1, im
- alpint(i,j,l) = log(pint(i,j,l))
- tvll = T(I,J,LL)*(Q(I,J,LL)*fv+1.0)
- pmll = log(PMID(I,J,LL))
-
-! if (me == 0 .and. i == ii .and. j == jj ) print*,'L ZINT= ',l,' tvll =', tvll, &
-! ' pmll=',pmll,' wrk2=',wrk2(i,j),' wrk1=',wrk1(i,j),' fi1=',fi(i,j,1), &
-! ' T=',T(i,j,LL),' Q=',Q(i,j,ll)
-
- FI(I,J,2) = FI(I,J,1) + (0.5*rgas)*(wrk2(i,j)+tvll) &
- * (wrk1(i,j)-pmll)
- ZMID(I,J,LL) = FI(I,J,2) * gravi
-!
- FACT = (ALPINT(I,J,L)-wrk1(i,j)) / (pmll-wrk1(i,j))
- ZINT(I,J,L) = ZMID(I,J,L) + (ZMID(I,J,LL)-ZMID(I,J,L)) * FACT
- FI(I,J,1) = FI(I,J,2)
- wrk1(i,J) = pmll
- wrk2(i,j) = tvll
-! if (me == 0 .and. i == ii .and. j == jj ) print*,'L ZINT= ',l,zint(ii,jj,l), &
-! 'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)),'pmid(l-1)=', &
-! LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L),'zmid(l-1)=',ZMID(Ii,Jj,L-1)
- ENDDO
- ENDDO
-
- if (me == 0) print*,'L ZINT= ',l,zint(ii,jj,l), &
- 'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)),'pmid(l-1)=', &
- LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L),'zmid(l-1)=',ZMID(Ii,Jj,L-1)
- ENDDO
- deallocate(wrk1,wrk2,fi)
-
-
- if (gocart_on) then
-
-! GFS output dust in nemsio (GOCART)
- do n=1,nbin_du
- do l=1,lm
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- dust(i,j,l,n) = spval
- enddo
- enddo
- enddo
- enddo
-! DUST = SPVAL
- VarName='du001'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,dust(1,jsta_2l,ll,1))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,1)
- end do ! do loop for l
-
- VarName='du002'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,dust(1,jsta_2l,ll,2))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,2)
- end do ! do loop for l
-
- VarName='du003'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,dust(1,jsta_2l,ll,3))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,3)
- end do ! do loop for l
-
- VarName='du004'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,dust(1,jsta_2l,ll,4))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,4)
- end do ! do loop for l
-
- VarName='du005'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,dust(1,jsta_2l,ll,5))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,5)
- end do ! do loop for l
-!
-! GFS output sea salt in nemsio (GOCART)
- do n=1,nbin_ss
- do l=1,lm
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- salt(i,j,l,n) = spval
- enddo
- enddo
- enddo
- enddo
-! SALT = SPVAL
- VarName='ss001'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,salt(1,jsta_2l,ll,1))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,1)
- end do ! do loop for l
-
- VarName='ss002'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,salt(1,jsta_2l,ll,2))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,2)
- end do ! do loop for l
-
- VarName='ss003'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,salt(1,jsta_2l,ll,3))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,3)
- end do ! do loop for l
-
- VarName='ss004'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,salt(1,jsta_2l,ll,4))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,4)
- end do ! do loop for l
-
- VarName='ss005'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,salt(1,jsta_2l,ll,5))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,5)
- end do ! do loop for l
-
-! GFS output black carbon in nemsio (GOCART)
- do n=1,nbin_oc
- do l=1,lm
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- soot(i,j,l,n) = spval
- enddo
- enddo
- enddo
- enddo
-! SOOT = SPVAL
- VarName='bcphobic'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,soot(1,jsta_2l,ll,1))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,soot(isa,jsa,ll,1)
- end do ! do loop for l
-
- VarName='bcphilic'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,soot(1,jsta_2l,ll,2))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,soot(isa,jsa,ll,2)
- end do ! do loop for l
-
-! GFS output organic carbon in nemsio (GOCART)
- do n=1,nbin_oc
- do l=1,lm
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- waso(i,j,l,n) = spval
- enddo
- enddo
- enddo
- enddo
-! WASO = SPVAL
- VarName='ocphobic'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,waso(1,jsta_2l,ll,1))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,waso(isa,jsa,ll,1)
- end do ! do loop for l
-
- VarName='ocphilic'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,waso(1,jsta_2l,ll,2))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,waso(isa,jsa,ll,2)
- end do ! do loop for l
-
-! GFS output sulfate in nemsio (GOCART)
- do n=1,nbin_su
- do l=1,lm
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- suso(i,j,l,n) = spval
- enddo
- enddo
- enddo
- enddo
-! SUSO = SPVAL
- VarName='so4'
- VcoordName='mid layer'
- do l=1,lm
- ll=lm-l+1
- call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,suso(1,jsta_2l,ll,1))
-! if(debugprint)print*,'sample l ',VarName,' = ',ll,suso(isa,jsa,ll,1)
- end do ! do loop for l
-
-
-! -- compute air density RHOMID and remove negative tracer values
- do l=1,lm
-!$omp parallel do private(i,j,n,tv)
- do j=jsta,jend
- do i=1,im
-
- TV = T(I,J,L) * (H1+D608*MAX(Q(I,J,L),QMIN))
- RHOMID(I,J,L) = PMID(I,J,L) / (RD*TV)
- do n = 1, NBIN_DU
- IF ( dust(i,j,l,n) < SPVAL) THEN
- DUST(i,j,l,n) = MAX(DUST(i,j,l,n), 0.0)
- ENDIF
- enddo
- do n = 1, NBIN_SS
- IF ( salt(i,j,l,n) < SPVAL) THEN
- SALT(i,j,l,n) = MAX(SALT(i,j,l,n), 0.0)
- ENDIF
- enddo
- do n = 1, NBIN_OC
- IF ( waso(i,j,l,n) < SPVAL) THEN
- WASO(i,j,l,n) = MAX(WASO(i,j,l,n), 0.0)
- ENDIF
- enddo
- do n = 1, NBIN_BC
- IF ( soot(i,j,l,n) < SPVAL) THEN
- SOOT(i,j,l,n) = MAX(SOOT(i,j,l,n), 0.0)
- ENDIF
- enddo
- do n = 1, NBIN_SU
- IF ( suso(i,j,l,n) < SPVAL) THEN
- SUSO(i,j,l,n) = MAX(SUSO(i,j,l,n), 0.0)
- ENDIF
- enddo
-
- end do
- end do
- end do
- endif ! endif for gocart_on
-!
-
-! PBL height using nemsio
- VarName='hpbl'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,pblh)
-! if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa)
-
-! frictional velocity using nemsio
- VarName='fricv'
-! VcoordName='sfc'
-! l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,ustar)
-! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa)
-
-! roughness length using getgb
- VarName='sfcr'
-! VcoordName='sfc'
-! l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,z0)
-! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa)
-
-! surface potential T using getgb
- VarName='tmp'
-! VcoordName='sfc'
-! l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,ths)
-
-! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (ths(i,j) /= spval) then
-! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1)
- ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa
- endif
- QS(i,j) = SPVAL ! GFS does not have surface specific humidity
- twbs(i,j) = SPVAL ! GFS does not have inst sensible heat flux
- qwbs(i,j) = SPVAL ! GFS does not have inst latent heat flux
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa)
-
-
-! GFS does not have time step and physics time step, make up ones since they
-! are not really used anyway
- NPHS=2.
- DT=80.
- DTQ2 = DT * NPHS !MEB need to get physics DT
- TSPH = 3600./DT !MEB need to get DT
-! All GFS time-averaged quantities are in 6 hour bucket
-! TPREC=6.0
-
-! convective precip in m per physics time step using gfsio
-! VarName='cprat'
-! VcoordName='sfc'
-! l=1
-! if(me == 0)then
-! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) &
-! + ,l,dummy,iret=iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! dummy=spval
-! else
-! do j = 1, jm
-! do i = 1, im
-! dummy(I,J)= dummy(i,j)*dtq2/1000. ! convert to m
-! if (j == jm/2 .and. mod(i,50) == 0)
-! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j)
-! enddo
-! enddo
-! end if
-! end if
-! call mpi_scatterv(dummy,icnt,idsp,mpi_real &
-! + , avgcprate(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret)
-! if (iret /= 0)print*,'Error scattering array';stop
-
-! convective precip in m per physics time step using getgb
- VarName='cprat'
-! VcoordName='sfc'
-! l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,avgcprate)
-! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001)
- cprate(i,j) = avgcprate(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa)
-
-! print*,'maxval CPRATE: ', maxval(CPRATE)
-
-! precip rate in m per physics time step using getgb
- VarName='prate'
-! VcoordName='sfc'
-! l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,avgprec)
-! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgprec(i,j) /= spval) avgprec(i,j) = avgprec(i,j) * (dtq2*0.001)
- enddo
- enddo
-
-! if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa)
-
- prec=avgprec !set avg cprate to inst one to derive other fields
-
-! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f
-
-
-! inst snow water eqivalent using nemsio
- VarName='weasd'
-! VcoordName='sfc'
-! l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,sno)
-! if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa)
-
-! snow depth in mm using nemsio
- VarName='snod'
-! VcoordName='sfc'
-! l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,si)
-! where(si /= spval)si=si*1000. ! convert to mm
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0
- CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency
- lspa(i,j) = spval ! GFS does not have similated precip
- TH10(i,j) = SPVAL ! GFS does not have 10 m theta
- TH10(i,j) = SPVAL ! GFS does not have 10 m theta
- Q10(i,j) = SPVAL ! GFS does not have 10 m humidity
- ALBASE(i,j) = SPVAL ! GFS does not have snow free albedo
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa)
-
-!!$omp parallel do private(i,j,l)
-! do l=1,lm
-! do j=jsta,jend
-! do i=1,im
-! Q2(i,j,l) = SPVAL ! GFS does not have TKE because it uses MRF scheme
-! ! GFS does not have surface exchange coeff
-! enddo
-! enddo
-! enddo
-
-! 2m T using nemsio
- VarName='tmp'
- VcoordName='2 m above gnd'
-! l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,tshltr)
-! if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa)
-
-! GFS does not have 2m pres, estimate it, also convert t to theta
- Do j=jsta,jend
- Do i=1,im
- PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j))
- tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta
-! if (j == jm/2 .and. mod(i,50) == 0)
-! + print*,'sample 2m T and P after scatter= '
-! + ,i,j,tshltr(i,j),pshltr(i,j)
- end do
- end do
-
-! 2m specific humidity using gfsio
-! VarName='spfh'
-! VcoordName='2m above gnc'
-! l=1
-! if(me == 0)then
-! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) &
-! + ,l,dummy,iret=iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! dummy=spval
-! end if
-! end if
-! call mpi_scatterv(dummy,icnt,idsp,mpi_real &
-! + ,qshltr(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret)
-! if (iret /= 0)print*,'Error scattering array';stop
-
-! 2m specific humidity using nemsio
- VarName='spfh'
- VcoordName='2 m above gnd'
-! l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,qshltr)
-! if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa)
-
-
-! mid day avg albedo in fraction using gfsio
-! VarName='albdo'
-! VcoordName='sfc'
-! l=1
-! if(me == 0)then
-! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) &
-! + ,l,dummy,iret=iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! dummy=spval
-! else
-! do j = 1, jm
-! do i = 1, im
-! dummy(I,J)= dummy(i,j)/100. ! convert to fraction
-! if (j == jm/2 .and. mod(i,50) == 0)
-! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j)
-! enddo
-! enddo
-! end if
-! end if
-! call mpi_scatterv(dummy,icnt,idsp,mpi_real &
-! + ,avgalbedo(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret)
-! if (iret /= 0)print*,'Error scattering array';stop
-
-! mid day avg albedo in fraction using nemsio
- VarName='albdo'
- VcoordName='sfc'
-! l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,avgalbedo)
-! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa)
-
-! time averaged column cloud fractionusing nemsio
- VarName='tcdc'
- VcoordName='atmos col'
-! l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,avgtcdc)
-! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa)
-
-! GFS probably does not use zenith angle
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- Czen(i,j) = spval
- CZMEAN(i,j) = SPVAL
- enddo
- enddo
-
-! maximum snow albedo in fraction using nemsio
- VarName='mxsalb'
- VcoordName='sfc'
-! l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,mxsnal)
-! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa)
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- radot(i,j) = spval ! GFS does not have inst surface outgoing longwave
- enddo
- enddo
-
-! GFS probably does not use sigt4, set it to sig*t^4
-!$omp parallel do private(i,j,tlmh)
- Do j=jsta,jend
- Do i=1,im
- TLMH = T(I,J,LM) * T(I,J,LM)
- Sigt4(i,j) = 5.67E-8 * TLMH * TLMH
- End do
- End do
-
-! TG is not used, skip it for now
-
-! will retrive f_ice when GFS switches to Ferrier scheme
-! varname='F_ICE'
-! call retrieve_index(index,VarName,varname_all,nrecs,iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! F_ice=SPVAL
-! else
-! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm
-! this_length=im*(jend_2u-jsta_2l+1)*lm
-! call mpi_file_read_at(iunit,this_offset
-! + ,buf3d,this_length,mpi_real4
-! + , mpi_status_ignore, ierr)
-! if (ierr /= 0) then
-! print*,"Error reading ", VarName,"Assigned missing values"
-! F_ice=SPVAL
-! else
-! do l = 1, lm
-! ll=lm-l+1
-! do j = jsta_2l, jend_2u
-! do i = 1, im
-! F_ice( i, j, l ) = buf3d ( i, ll, j )
-! if(i == im/2.and.j == (jsta+jend)/2)print*,'sample F_ice= ',
-! + i,j,l,F_ice( i, j, l )
-! end do
-! end do
-! end do
-! end if
-! end if
-
-! varname='F_RAIN'
-! call retrieve_index(index,VarName,varname_all,nrecs,iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! F_rain=SPVAL
-! else
-! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm
-! this_length=im*(jend_2u-jsta_2l+1)*lm
-! call mpi_file_read_at(iunit,this_offset
-! + ,buf3d,this_length,mpi_real4
-! + , mpi_status_ignore, ierr)
-! if (ierr /= 0) then
-! print*,"Error reading ", VarName,"Assigned missing values"
-! F_rain=SPVAL
-! else
-! do l = 1, lm
-! ll=lm-l+1
-! do j = jsta_2l, jend_2u
-! do i = 1, im
-! F_rain( i, j, l ) = buf3d ( i, ll, j )
-! if(i == im/2.and.j == (jsta+jend)/2)print*,'sample F_rain= ',
-! + i,j,l,F_rain( i, j, l )
-! end do
-! end do
-! end do
-! end if
-! end if
-
-! varname='F_RIMEF'
-! call retrieve_index(index,VarName,varname_all,nrecs,iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! F_RimeF=SPVAL
-! else
-! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm
-! this_length=im*(jend_2u-jsta_2l+1)*lm
-! call mpi_file_read_at(iunit,this_offset
-! + ,buf3d,this_length,mpi_real4
-! + , mpi_status_ignore, ierr)
-! if (ierr /= 0) then
-! print*,"Error reading ", VarName,"Assigned missing values"
-! F_RimeF=SPVAL
-! else
-! do l = 1, lm
-! ll=lm-l+1
-! do j = jsta_2l, jend_2u
-! do i = 1, im
-! F_RimeF( i, j, l ) = buf3d ( i, ll, j )
-! if(i == im/2.and.j == (jsta+jend)/2)print*,
-! + 'sample F_RimeF= ',i,j,l,F_RimeF( i, j, l )
-! end do
-! end do
-! end do
-! end if
-! end if
-
-! GFS does not have model level cloud fraction -> derive cloud fraction
-! CFR=SPVAL
-! allocate(qstl(lm))
-! print*,'start deriving cloud fraction'
-
-! do j=jsta,jend
-! do i=1,im
-! do l=1,lm
-! if(i==im/2.and.j==jsta)print*,'sample T=',t(i,j,l)
-! es=fpvsnew(t(i,j,l))
-! if(i==im/2.and.j==jsta)print*,'sample ES=',es
-! es=min(es,pmid(i,j,l))
-! if(i==im/2.and.j==jsta)print*,'sample ES=',es
-! qstl(l)=con_eps*es/(pmid(i,j,l)+con_epsm1*es) !saturation q for GFS
-! end do
-! call progcld1
-!...................................
-
-! --- inputs:
-! & ( pmid(i,j,1:lm)/100.,pint(i,j,1:lm+1)/100.,
-! & t(i,j,1:lm),q(i,j,1:lm),qstl,cwm(i,j,1:lm),
-! & gdlat(i,j),gdlon(i,j),
-! & 1, lm, lm+1, 0,
-! --- outputs:
-! & cfr(i,j,1:lm)
-! & )
-! do l=1,lm
-! cfr(i,j,l)=cldtot(l)
-! end do
-! end do
-! end do
- allocate(p2d(im,lm),t2d(im,lm),q2d(im,lm),cw2d(im,lm), &
- qs2d(im,lm),cfr2d(im,lm))
- do j=jsta,jend
-!$omp parallel do private(i,k,es)
- do k=1,lm
- do i=1,im
- p2d(i,k) = pmid(i,j,k)*0.01
- t2d(i,k) = t(i,j,k)
- q2d(i,k) = q(i,j,k)
- cw2d(i,k) = cwm(i,j,k)
- es = min(fpvsnew(t(i,j,k)),pmid(i,j,k))
- qs2d(i,k) = eps*es/(pmid(i,j,k)+epsm1*es)!saturation q for GFS
- enddo
- enddo
- call progcld1 &
-!...................................
-! --- inputs:
- ( p2d,t2d,q2d,qs2d,cw2d,im,lm,0, &
-! --- outputs:
- cfr2d &
- )
-!$omp parallel do private(i,k)
- do k=1,lm
- do i=1,im
- cfr(i,j,k) = cfr2d(i,k)
- enddo
- end do
- end do
- deallocate(p2d,t2d,q2d,qs2d,cw2d,cfr2d)
-
-
-! ask murthy if there is snow rate in GFS
-! varname='SR'
-! call retrieve_index(index,VarName,varname_all,nrecs,iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! SR=SPVAL
-! else
-! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im
-! this_length=im*(jend_2u-jsta_2l+1)
-! call mpi_file_read_at(iunit,this_offset
-! + ,sr,this_length,mpi_real4
-! + , mpi_status_ignore, ierr)
-! if (ierr /= 0) then
-! print*,"Error reading ", VarName,"Assigned missing values"
-! SR=SPVAL
-! end if
-! end if
-
-! GFS does not have inst cloud fraction for high, middle, and low cloud
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- cfrach(i,j) = spval
- cfracl(i,j) = spval
- cfracm(i,j) = spval
- enddo
- enddo
-
-! ave high cloud fraction using nemsio
- VarName='tcdc'
- VcoordName='high cld lay'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,avgcfrach)
-! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa)
-
-! ave low cloud fraction using nemsio
- VarName='tcdc'
- VcoordName='low cld lay'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,avgcfracl)
-! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa)
-
-! ave middle cloud fraction using nemsio
- VarName='tcdc'
- VcoordName='mid cld lay'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,avgcfracm)
-! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa)
-
-! inst convective cloud fraction using nemsio
- VarName='tcdc'
- VcoordName='convect-cld laye'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,cnvcfr)
-! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa)
-
-! slope type using nemsio
- VarName='sltyp'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,buf)
-! where(buf /= spval)islope=nint(buf)
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- if (buf(i,j) < spval) then
- islope(i,j) = nint(buf(i,j))
- else
- islope(i,j) = 0
- endif
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa)
-
-! plant canopy sfc wtr in m using nemsio
- VarName='cnwat'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,cmc)
-! where(cmc /= spval)cmc=cmc/1000. ! convert from kg*m^2 to m
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa)
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- grnflx(i,j) = spval ! GFS does not have inst ground heat flux
- enddo
- enddo
-
-! GFS does not have snow cover yet
-! VarName='gflux'
-! VcoordName='sfc'
-! l=1
-! if(me == 0)then
-! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) &
-! + ,l,dummy,iret=iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! dummy=spval
-! end if
-! end if
-! call mpi_scatterv(dummy,icnt,idsp,mpi_real &
-! + , pctsno(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret)
-! if (iret /= 0)print*,'Error scattering array';stop
-
-! asuume tg3 in GFS is the same as soiltb in wrf nmm. It's in sfc file, will
-! be able to read it when it merges to gfs io
-! soiltb is not being put out, comment it out
-! VarName='tg3'
-! VcoordName='sfc'
-! l=1
-! if(me == 0)then
-! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) &
-! ,l,dummy,iret=iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! dummy=spval
-! end if
-! end if
-! call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real &
-! , soiltb(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret)
-! if (iret /= 0)print*,'Error scattering array';stop
-
-! vegetation fraction in fraction. using nemsio
- VarName='veg'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,vegfrc)
-! where(vegfrc /= spval)
-! vegfrc=vegfrc/100. ! convert to fraction
-! elsewhere (vegfrc == spval)
-! vegfrc=0. ! set to zero to be reasonable input for crtm
-! end where
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (vegfrc(i,j) /= spval) then
- vegfrc(i,j) = vegfrc(i,j) * 0.01
- else
- vegfrc(i,j) = 0.0
- endif
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa)
-
-! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam
-
- SLDPTH(1) = 0.10
- SLDPTH(2) = 0.3
- SLDPTH(3) = 0.6
- SLDPTH(4) = 1.0
-
-! liquid volumetric soil mpisture in fraction using nemsio
- VarName='soill'
- VcoordName='0-10 cm down'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,sh2o(1,jsta_2l,1))
-! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1)
-
- VarName='soill'
- VcoordName='10-40 cm down'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,sh2o(1,jsta_2l,2))
-! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2)
-
- VarName='soill'
- VcoordName='40-100 cm down'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,sh2o(1,jsta_2l,3))
-! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3)
-
- VarName='soill'
- VcoordName='100-200 cm down'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,sh2o(1,jsta_2l,4))
-! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4)
-
-! volumetric soil moisture using nemsio
- VarName='soilw'
- VcoordName='0-10 cm down'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,smc(1,jsta_2l,1))
-! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1)
-
- VarName='soilw'
- VcoordName='10-40 cm down'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,smc(1,jsta_2l,2))
-! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2)
-
- VarName='soilw'
- VcoordName='40-100 cm down'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,smc(1,jsta_2l,3))
-! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3)
-
- VarName='soilw'
- VcoordName='100-200 cm down'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,smc(1,jsta_2l,4))
-! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4)
-
-! soil temperature using nemsio
- VarName='tmp'
- VcoordName='0-10 cm down'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,stc(1,jsta_2l,1))
-! if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1)
-
- VarName='tmp'
- VcoordName='10-40 cm down'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,stc(1,jsta_2l,2))
-! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2)
-
- VarName='tmp'
- VcoordName='40-100 cm down'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,stc(1,jsta_2l,3))
-! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3)
-
- VarName='tmp'
- VcoordName='100-200 cm down'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,stc(1,jsta_2l,4))
-! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4)
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1
- ncfrcv(i,j) = 1.0
- acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1
- ncfrst(i,j) = 1.0
- ssroff(i,j) = spval ! GFS does not have storm runoff
- bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF
- rlwin(i,j) = spval ! GFS does not have inst incoming sfc longwave
- rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave
- enddo
- enddo
-! trdlw(i,j) = 6.0
- ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1
-
-! time averaged incoming sfc longwave using nemsio
- VarName='dlwrf'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,alwin)
-
-! time averaged outgoing sfc longwave using gfsio
- VarName='ulwrf'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,alwout)
-! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa)
-
-! time averaged outgoing model top longwave using gfsio
- VarName='ulwrf'
- VcoordName='nom. top'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,alwtoa)
-! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa)
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- rswin(i,j) = spval ! GFS does not have inst incoming sfc shortwave
- rswinc(i,j) = spval ! GFS does not have inst incoming clear sky sfc shortwave
- rswout(i,j) = spval ! GFS does not have inst outgoing sfc shortwave
- enddo
- enddo
-
-! GFS incoming sfc longwave has been averaged, set ARDLW to 1
- ardsw=1.0
-! trdsw=6.0
-
-! time averaged incoming sfc shortwave using gfsio
- VarName='dswrf'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,aswin)
-! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa)
-
-! time averaged incoming sfc uv-b using getgb
- VarName='duvb'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,auvbin)
-! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa)
-
-! time averaged incoming sfc clear sky uv-b using getgb
- VarName='cduvb'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,auvbinc)
-! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa)
-
-! time averaged outgoing sfc shortwave using gfsio
- VarName='uswrf'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,aswout)
-! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa)
-
-! time averaged model top incoming shortwave
- VarName='dswrf'
- VcoordName='nom. top'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,aswintoa)
-
-! time averaged model top outgoing shortwave
- VarName='uswrf'
- VcoordName='nom. top'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,aswtoa)
-! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa)
-
-! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux
-! has reversed sign convention using gfsio
- VarName='shtfl'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,sfcshx)
-! where (sfcshx /= spval)sfcshx=-sfcshx
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa)
-
-! GFS surface flux has been averaged, set ASRFC to 1
- asrfc=1.0
-! tsrfc=6.0
-
-! time averaged surface latent heat flux, multiplied by -1 because wrf model flux
-! has reversed sign vonvention using gfsio
- VarName='lhtfl'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,sfclhx)
-! where (sfclhx /= spval)sfclhx=-sfclhx
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa)
-
-! time averaged ground heat flux using nemsio
- VarName='gflux'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,subshx)
-! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa)
-
-! time averaged zonal momentum flux using gfsio
- VarName='uflx'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,sfcux)
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa)
-
-! time averaged meridional momentum flux using nemsio
- VarName='vflx'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,sfcvx)
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa)
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- snopcx(i,j) =spval ! GFS does not have snow phase change heat flux
- sfcuvx(i,j) = spval ! GFS does not use total momentum flux
- enddo
- enddo
-
-! time averaged zonal gravity wave stress using nemsio
- VarName='u-gwd'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,gtaux)
-! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa)
-
-! time averaged meridional gravity wave stress using getgb
- VarName='v-gwd'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,gtauy)
-! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa)
-
-! time averaged accumulated potential evaporation
- VarName='pevpr'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,potevp)
-! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa)
-
- do l=1,lm
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
-! GFS does not have temperature tendency due to long wave radiation
- rlwtt(i,j,l) = spval
-! GFS does not have temperature tendency due to short wave radiation
- rswtt(i,j,l) = spval
-! GFS does not have temperature tendency due to latent heating from convection
- tcucn(i,j,l) = spval
- tcucns(i,j,l) = spval
-! GFS does not have temperature tendency due to latent heating from grid scale
- train(i,j,l) = spval
- enddo
- enddo
- enddo
-
-! set avrain to 1
- avrain=1.0
- avcnvc=1.0
- theat=6.0 ! just in case GFS decides to output T tendency
-
-! 10 m u using nemsio
- VarName='ugrd'
- VcoordName='10 m above gnd'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,u10)
-! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa)
- do j=jsta,jend
- do i=1,im
- u10h(i,j)=u10(i,j)
- end do
- end do
-
-! 10 m v using gfsio
- VarName='vgrd'
- VcoordName='10 m above gnd'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,v10)
- do j=jsta,jend
- do i=1,im
- v10h(i,j)=v10(i,j)
- end do
- end do
-! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa)
-
-! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon
- VarName='vgtyp'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,buf)
-! where (buf /= spval)
-! ivgtyp=nint(buf)
-! elsewhere
-! ivgtyp=0 !need to feed reasonable value to crtm
-! end where
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- if (buf(i,j) < spval) then
- ivgtyp(i,j) = nint(buf(i,j))
- else
- ivgtyp(i,j) = 0
- endif
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa)
-
-! soil type, it's in GFS surface file, hopefully will merge into gfsio soon
- VarName='sotyp'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,buf)
-! where (buf /= spval)
-! isltyp=nint(buf)
-! elsewhere
-! isltyp=0 !need to feed reasonable value to crtm
-! end where
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- if (buf(i,j) < spval) then
- isltyp(i,j) = nint(buf(i,j))
- else
- isltyp(i,j) = 0
- endif
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa)
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- smstav(i,j) = spval ! GFS does not have soil moisture availability
- smstot(i,j) = spval ! GFS does not have total soil moisture
- sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation
- sfcexc(i,j) = spval ! GFS does not have surface exchange coefficient
- acsnow(i,j) = spval ! GFS does not have averaged accumulated snow
- acsnom(i,j) = spval ! GFS does not have snow melt
- sst(i,j) = spval ! GFS does not have sst????
- thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute
- qz0(i,j) = spval ! GFS does not output humidity at roughness length
- uz0(i,j) = spval ! GFS does not output u at roughness length
- vz0(i,j) = spval ! GFS does not output humidity at roughness length
- enddo
- enddo
- do l=1,lm
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- EL_PBL(i,j,l) = spval ! GFS does not have mixing length
- exch_h(i,j,l) = spval ! GFS does not output exchange coefficient
- enddo
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa)
-
-! retrieve inst convective cloud top, GFS has cloud top pressure instead of index,
-! will need to modify CLDRAD.f to use pressure directly instead of index
- VarName='pres'
- VcoordName='convect-cld top'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,ptop)
-! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa)
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- htop(i,j) = spval
- if(ptop(i,j) <= 0.0) ptop(i,j) = spval
- enddo
- enddo
- do j=jsta,jend
- do i=1,im
- if(ptop(i,j) < spval)then
- do l=1,lm
- if(ptop(i,j) <= pmid(i,j,l))then
- htop(i,j) = l
-! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', &
-! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j)
- exit
- end if
- end do
- end if
- end do
- end do
-
-! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index,
-! will need to modify CLDRAD.f to use pressure directly instead of index
- VarName='pres'
- VcoordName='convect-cld bot'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,pbot)
-! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa)
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- hbot(i,j) = spval
- if(pbot(i,j) <= 0.0) pbot(i,j) = spval
- enddo
- enddo
- do j=jsta,jend
- do i=1,im
-! if(.not.lb(i,j))print*,'false bitmask for pbot at '
-! + ,i,j,pbot(i,j)
- if(pbot(i,j) < spval)then
- do l=lm,1,-1
- if(pbot(i,j) >= pmid(i,j,l)) then
- hbot(i,j) = l
-! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', &
-! pbot(i,j),pmid(i,j,l),hbot(i,j)
- exit
- end if
- end do
- end if
- end do
- end do
-
-! retrieve time averaged low cloud top pressure using nemsio
- VarName='pres'
- VcoordName='low cld top'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,ptopl)
-! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa)
-
-! retrieve time averaged low cloud bottom pressure using nemsio
- VarName='pres'
- VcoordName='low cld bot'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,pbotl)
-! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa)
-
-! retrieve time averaged low cloud top temperature using nemsio
- VarName='tmp'
- VcoordName='low cld top'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,Ttopl)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa)
-
-! retrieve time averaged middle cloud top pressure using nemsio
- VarName='pres'
- VcoordName='mid cld top'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,ptopm)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa)
-
-! retrieve time averaged middle cloud bottom pressure using nemsio
- VarName='pres'
- VcoordName='mid cld bot'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,pbotm)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa)
-
-! retrieve time averaged middle cloud top temperature using nemsio
- VarName='tmp'
- VcoordName='mid cld top'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,Ttopm)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa)
-
-! retrieve time averaged high cloud top pressure using nemsio *********
- VarName='pres'
- VcoordName='high cld top'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,ptoph)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa)
-
-! retrieve time averaged high cloud bottom pressure using nemsio
- VarName='pres'
- VcoordName='high cld bot'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,pboth)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa)
-
-! retrieve time averaged high cloud top temperature using nemsio
- VarName='tmp'
- VcoordName='high cld top'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,Ttoph)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa)
-
-! retrieve boundary layer cloud cover using nemsio
- VarName='tcdc'
- VcoordName='bndary-layer cld'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,pblcfr)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa)
-! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01
- enddo
- enddo
-
-! retrieve cloud work function using nemsio
- VarName='cwork'
- VcoordName='atmos col'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,cldwork)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa)
-
-! retrieve water runoff using nemsio
- VarName='watr'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,runoff)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa)
-
-! retrieve shelter max temperature using nemsio
- VarName='tmax'
- VcoordName='2 m above gnd'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,maxtshltr)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,maxtshltr(isa,jsa)
-
-! retrieve shelter max temperature using nemsio
- VarName='tmin'
- VcoordName='2 m above gnd'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,mintshltr)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', &
-! 1,mintshltr(im/2,(jsta+jend)/2)
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- MAXRHSHLTR(i,j) = SPVAL
- MINRHSHLTR(i,j) = SPVAL
- enddo
- enddo
-
-! retrieve ice thickness using nemsio
- VarName='icetk'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,dzice)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa)
-
-! retrieve wilting point using nemsio
- VarName='wilt'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,smcwlt)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa)
-
-! retrieve sunshine duration using nemsio
- VarName='sunsd'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,suntime)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,suntime(isa,jsa)
-
-! retrieve field capacity using nemsio
- VarName='fldcp'
- VcoordName='sfc'
- l=1
- call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,fieldcapa)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa)
-
-! GFS does not have deep convective cloud top and bottom fields
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- HTOPD(i,j) = SPVAL
- HBOTD(i,j) = SPVAL
- HTOPS(i,j) = SPVAL
- HBOTS(i,j) = SPVAL
- CUPPT(i,j) = SPVAL
- enddo
- enddo
-
-!
-!!!! DONE GETTING
-! Will derive isobaric OMEGA from continuity equation later.
-! OMGA=SPVAL
-!
-!
-! retrieve d3d fields if it's listed
-! ----------------------------------
- if (me == 0) print*,'iostatus for d3d file= ',iostatusD3D
- if(iostatusD3D == 0) then ! start reading d3d file
-! retrieve longwave tendency using getgb
- Index=41
- VarName='LW RAD TEMP TNDY'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=251
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,rlwtt(1,jsta_2l,ll))
- end do
-
-! retrieve shortwave tendency using getgb
- Index=40
- VarName='SW RAD TEMP TNDY'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=250
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,rswtt(1,jsta_2l,ll))
- end do
-
-! retrieve vertical diffusion tendency using getgb
- Index=356
- VarName='VDIFF TNDY'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=246
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,vdifftt(1,jsta_2l,ll))
- end do
-
-! retrieve deep convective tendency using getgb
- Index=79
- VarName='AVE CNVCT RN TMPTDY'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=242
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,tcucn(1,jsta_2l,ll))
- end do
-
-! retrieve shallow convective tendency using getgb
- Index=358
- VarName='S CNVCT TNDY'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=244
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,tcucns(1,jsta_2l,ll))
- end do
-
-! retrieve grid scale latent heat tendency using getgb
- Index=78
- VarName='AVE GRDSCL RN TMPTDY'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=241
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,train(1,jsta_2l,ll))
- end do
-
-! retrieve vertical diffusion moistening using getgb
- Index=360
- VarName='Vertical diffusion moistening'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=249
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,vdiffmois(1,jsta_2l,ll))
- end do
-
-! retrieve deep convection moistening using getgb
- Index=361
- VarName='deep convection moistening'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=243
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,dconvmois(1,jsta_2l,ll))
- end do
-
-! retrieve shallow convection moistening using getgb
- Index=362
- VarName='shallow convection moistening'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=245
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,sconvmois(1,jsta_2l,ll))
- end do
-
-! retrieve non-radiation tendency using getgb
- Index=363
- VarName='non-radiation tendency'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=173
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,nradtt(1,jsta_2l,ll))
- end do
-
-! retrieve Vertical diffusion of ozone using getgb
- Index=364
- VarName='Vertical diffusion of ozone'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=174
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,o3vdiff(1,jsta_2l,ll))
- end do
-
-! retrieve ozone production using getgb
- Index=365
- VarName='Ozone production'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=175
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,o3prod(1,jsta_2l,ll))
- end do
-
-! retrieve ozone tendency using getgb
- Index=366
- VarName='Ozone tendency'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=188
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,o3tndy(1,jsta_2l,ll))
- end do
-
-! retrieve mass weighted PV using getgb
- Index=367
- VarName='Mass weighted PV'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=139
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,mwpv(1,jsta_2l,ll))
- end do
-
-! retrieve OZONE TNDY using getgb
- Index=368
- VarName='?'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=239
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,unknown(1,jsta_2l,ll))
- end do
-
-! retrieve vertical diffusion zonal acceleration
- Index=369
- VarName='VDIFF Z ACCE'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=247
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,vdiffzacce(1,jsta_2l,ll))
- end do
-
-! retrieve gravity drag zonal acceleration
- Index=370
- VarName='G DRAG Z ACCE'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=181
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,zgdrag(1,jsta_2l,ll))
- end do
-
-! retrieve convective U momemtum mixing
- Index=371
- VarName='CNVCT U M MIX'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=183
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,cnvctummixing(1,jsta_2l,ll))
- end do
-
-! retrieve vertical diffusion meridional acceleration
- Index=372
- VarName='VDIFF M ACCE'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=248
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,vdiffmacce(1,jsta_2l,ll))
- end do
-
-! retrieve gravity drag meridional acceleration
- Index=373
- VarName='G DRAG M ACCE'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=182
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,mgdrag(1,jsta_2l,ll))
- end do
-
-! retrieve convective V momemtum mixing
- Index=374
- VarName='CNVCT V M MIX'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=184
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,cnvctvmmixing(1,jsta_2l,ll))
- end do
-
-! retrieve nonconvective cloud fraction
- Index=375
- VarName='N CNVCT CLD FRA'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=213
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,ncnvctcfrac(1,jsta_2l,ll))
- end do
-
-! retrieve convective upward mass flux
- Index=391
- VarName='CNVCT U M FLX'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=202
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,cnvctumflx(1,jsta_2l,ll))
- end do
-
-! retrieve convective downward mass flux
- Index=392
- VarName='CNVCT D M FLX'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=209
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,cnvctdmflx(1,jsta_2l,ll))
- end do
-
-! retrieve nonconvective detraintment flux
- Index=393
- VarName='CNVCT DET M FLX'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=219
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,cnvctdetmflx(1,jsta_2l,ll))
- end do
-
-! retrieve cnvct gravity drag zonal acceleration
- Index=394
- VarName='CNVCT G DRAG Z ACCE'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=196
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,cnvctzgdrag(1,jsta_2l,ll))
- end do
-
-! retrieve cnvct gravity drag meridional acceleration
- Index=395
- VarName='CNVCT G DRAG M ACCE'
- jpds=-1.0
- jgds=-1.0
- jpds(5)=197
- jpds(6)=109
- do l=1,lm
- jpds(7)=l
- ll=lm-l+1 !flip 3d fields to count from top down
- call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,jpds,jgds,kpds,cnvctmgdrag(1,jsta_2l,ll))
- end do
-
- call baclose(iunitd3d,status)
- print*,'done reading D3D fields'
-
- end if ! end of d3d file read
- ! --------------------
- print *,'after d3d files reading,mype=',me
-
-! Retrieve aer fields if it's listed (GOCART)
- print *, 'iostatus for aer file=', iostatusAER
- if(iostatusAER == 0) then ! start reading aer file
-
-! retrieve dust emission fluxes
- do K = 1, nbin_du
- if ( K == 1) VarName='DUEM001'
- if ( K == 2) VarName='DUEM002'
- if ( K == 3) VarName='DUEM003'
- if ( K == 4) VarName='DUEM004'
- if ( K == 5) VarName='DUEM005'
- VcoordName='atmos col'
- l=1
- call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,duem(1,jsta_2l,K))
-! if(debugprint)print*,'sample ',VarName,' = ',duem(isa,jsa,k)
- enddo
-
-! retrieve dust sedimentation fluxes
- do K = 1, nbin_du
- if ( K == 1) VarName='DUSD001'
- if ( K == 2) VarName='DUSD002'
- if ( K == 3) VarName='DUSD003'
- if ( K == 4) VarName='DUSD004'
- if ( K == 5) VarName='DUSD005'
- VcoordName='atmos col'
- l=1
- call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,dusd(1,jsta_2l,K))
-! if(debugprint)print*,'sample ',VarName,' = ',dusd(isa,jsa,k)
- enddo
-
-! retrieve dust dry deposition fluxes
- do K = 1, nbin_du
- if ( K == 1) VarName='DUDP001'
- if ( K == 2) VarName='DUDP002'
- if ( K == 3) VarName='DUDP003'
- if ( K == 4) VarName='DUDP004'
- if ( K == 5) VarName='DUDP005'
- VcoordName='atmos col'
- l=1
- call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,dudp(1,jsta_2l,K))
- print *,'dudp,ck=',maxval(dudp(1:im,jsta:jend,k)), &
- minval(dudp(1:im,jsta:jend,k))
-! if(debugprint)print*,'sample ',VarName,' = ',dudp(isa,jsa,k)
- enddo
-
-! retrieve dust wet deposition fluxes
- do K = 1, nbin_du
- if ( K == 1) VarName='DUWT001'
- if ( K == 2) VarName='DUWT002'
- if ( K == 3) VarName='DUWT003'
- if ( K == 4) VarName='DUWT004'
- if ( K == 5) VarName='DUWT005'
- VcoordName='atmos col'
- l=1
- call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,duwt(1,jsta_2l,K))
-! if(debugprint)print*,'sample ',VarName,' = ',duwt(isa,jsa,k)
- enddo
-
-! retrieve sfc mass concentration
- VarName='DUSMASS'
- VcoordName='atmos col'
- l=1
- call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,dusmass)
-! if(debugprint)print*,'sample ',VarName,' = ',dusmass(isa,jsa)
-
-! retrieve col mass density
- VarName='DUCMASS'
- VcoordName='atmos col'
- l=1
- call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,ducmass)
-! if(debugprint)print*,'sample ',VarName,' = ',ducmass(isa,jsa)
-
-! retrieve sfc mass concentration (pm2.5)
- VarName='DUSMASS25'
- VcoordName='atmos col'
- l=1
- call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,dusmass25)
-! if(debugprint)print*,'sample ',VarName,' = ',dusmass25(isa,jsa)
-
-! retrieve col mass density (pm2.5)
- VarName='DUCMASS25'
- VcoordName='atmos col'
- l=1
- call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName &
- ,l,im,jm,nframe,ducmass25)
-! if(debugprint)print*,'sample ',VarName,' = ',ducmass25(isa,jsa)
-
- if (me == 0) print *,'after aer files reading,mype=',me
- end if ! end of aer file read
-
-! pos east
- call collect_loc(gdlat,dummy)
- if(me == 0)then
- latstart = nint(dummy(1,1)*gdsdegr)
- latlast = nint(dummy(im,jm)*gdsdegr)
- print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,&
- 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1)
- end if
- call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn)
- call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn)
- write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me
- call collect_loc(gdlon,dummy)
- if(me == 0)then
- lonstart = nint(dummy(1,1)*gdsdegr)
- lonlast = nint(dummy(im,jm)*gdsdegr)
- end if
- call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn)
- call mpi_bcast(lonlast, 1,MPI_INTEGER,0,mpi_comm_comp,irtn)
-
- write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast
-!
-! ncdump -h
-!!
-!!
- write(6,*) 'filename in INITPOST=', filename,' is'
-
-! status=nf_open(filename,NF_NOWRITE,ncid)
-! write(6,*) 'returned ncid= ', ncid
-! status=nf_get_att_real(ncid,varid,'DX',tmp)
-! dxval=int(tmp)
-! status=nf_get_att_real(ncid,varid,'DY',tmp)
-! dyval=int(tmp)
-! status=nf_get_att_real(ncid,varid,'CEN_LAT',tmp)
-! cenlat=int(1000.*tmp)
-! status=nf_get_att_real(ncid,varid,'CEN_LON',tmp)
-! cenlon=int(1000.*tmp)
-! status=nf_get_att_real(ncid,varid,'TRUELAT1',tmp)
-! truelat1=int(1000.*tmp)
-! status=nf_get_att_real(ncid,varid,'TRUELAT2',tmp)
-! truelat2=int(1000.*tmp)
-! status=nf_get_att_real(ncid,varid,'MAP_PROJ',tmp)
-! maptype=int(tmp)
-! status=nf_close(ncid)
-
-! dxval=30000.
-! dyval=30000.
-!
-! write(6,*) 'dxval= ', dxval
-! write(6,*) 'dyval= ', dyval
-! write(6,*) 'cenlat= ', cenlat
-! write(6,*) 'cenlon= ', cenlon
-! write(6,*) 'truelat1= ', truelat1
-! write(6,*) 'truelat2= ', truelat2
-! write(6,*) 'maptype is ', maptype
-!
-
-! close up shop
-! call ext_int_ioclose ( DataHandle, Status )
-
-! generate look up table for lifted parcel calculations
-
- THL = 210.
- PLQ = 70000.
- pt_TBL = 10000. ! this is for 100 hPa added by Moorthi
-
- CALL TABLE(PTBL,TTBL,PT_TBL, &
- RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0)
-
- CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q)
-
-!
-!
- IF(ME == 0)THEN
- WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: '
- WRITE(6,51) (SPL(L),L=1,LSM)
- 50 FORMAT(14(F4.1,1X))
- 51 FORMAT(8(F8.1,1X))
- ENDIF
-!
-! COMPUTE DERIVED TIME STEPPING CONSTANTS.
-!
-!MEB need to get DT
-! DT = 120. !MEB need to get DT
-! NPHS = 4 !MEB need to get physics DT
-! TPREC=float(ifhr)
-!MEB need to get DT
-
-!how am i going to get this information?
-! NPREC = INT(TPREC *TSPH+D50)
-! NHEAT = INT(THEAT *TSPH+D50)
-! NCLOD = INT(TCLOD *TSPH+D50)
-! NRDSW = INT(TRDSW *TSPH+D50)
-! NRDLW = INT(TRDLW *TSPH+D50)
-! NSRFC = INT(TSRFC *TSPH+D50)
-!how am i going to get this information?
-!
-! IF(ME == 0)THEN
-! WRITE(6,*)' '
-! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS'
-! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC
-! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW
-! ENDIF
-!
-! COMPUTE DERIVED MAP OUTPUT CONSTANTS.
-!$omp parallel do private(l)
- DO L = 1,LSM
- ALSL(L) = LOG(SPL(L))
- END DO
-!
-!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN
- if(me == 0)then
- print*,'writing out igds'
- igdout = 110
-! open(igdout,file='griddef.out',form='unformatted'
-! + ,status='unknown')
- if(maptype == 1)THEN ! Lambert conformal
- WRITE(igdout)3
- WRITE(6,*)'igd(1)=',3
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)8
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)0
- WRITE(igdout)64
- WRITE(igdout)TRUELAT2
- WRITE(igdout)TRUELAT1
- WRITE(igdout)255
- ELSE IF(MAPTYPE == 2)THEN !Polar stereographic
- WRITE(igdout)5
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)8
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)0
- WRITE(igdout)64
- WRITE(igdout)TRUELAT2 !Assume projection at +-90
- WRITE(igdout)TRUELAT1
- WRITE(igdout)255
- ! Note: The calculation of the map scale factor at the standard
- ! lat/lon and the PSMAPF
- ! Get map factor at 60 degrees (N or S) for PS projection, which will
- ! be needed to correctly define the DX and DY values in the GRIB GDS
- if (TRUELAT1 < 0.) THEN
- LAT = -60.
- else
- LAT = 60.
- end if
-
- CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF)
-
- ELSE IF(MAPTYPE == 3) THEN !Mercator
- WRITE(igdout)1
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)8
- WRITE(igdout)latlast
- WRITE(igdout)lonlast
- WRITE(igdout)TRUELAT1
- WRITE(igdout)0
- WRITE(igdout)64
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)255
- ELSE IF(MAPTYPE == 0 .OR. MAPTYPE == 203)THEN !A STAGGERED E-GRID
- WRITE(igdout)203
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)136
- WRITE(igdout)CENLAT
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)64
- WRITE(igdout)0
- WRITE(igdout)0
- WRITE(igdout)0
- END IF
- end if
-!
-! close all files
-!
- call nemsio_close(nfile,iret=status)
- call nemsio_close(ffile,iret=status)
- call nemsio_close(rfile,iret=status)
-! call baclose(iunit,status)
-
- RETURN
- END
-
-
diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f b/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f
index 4714cfc3d..cca50d7b2 100644
--- a/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f
+++ b/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f
@@ -1,51 +1,31 @@
!> @file
-! . . .
-!> SUBPROGRAM: INITPOST_GFS_NEMS_MPIIO INITIALIZE POST FOR RUN
-!! PRGRMMR: Hui-Ya Chuang DATE: 2016-03-04
-!!
-!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND
-!! VARIABLES AT THE START OF GFS MODEL OR POST
-!! PROCESSOR RUN.
-!!
-!! REVISION HISTORY
-!! 2011-02-07 Jun Wang add grib2 option
-!! 2011-12-14 Sarah Lu add aer option
-!! 2012-01-07 Sarah Lu compute air density
-!! 2012-12-22 Sarah Lu add aerosol zerout option
-!! 2015-03-16 S. Moorthi adding gocart_on option
-!! 2015-03-18 S. Moorthi Optimization including threading
-!! 2015-08-17 S. Moorthi Add TKE for NEMS/GSM
-!! 2016-03-04 H CHUANG Add MPI IO option to read GFS nems output
-!! 2016-05-16 S. KAR Add computation of omega
-!! 2016-07-21 S. Moorthi Convert input upper air data from reduced to full grid
-!! and reduce memory in divergence calculatiom
-!! 2016-07-21 Jun Wang change averaged field name with suffix
-!! 2019-07-24 Li(Kate) Zhang - Merge and update NGAC UPP into FV3-Chem
-!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend)
-!!
-!! USAGE: CALL INIT
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! NONE
-!! LIBRARY:
-!! COMMON - CTLBLK
-!! LOOKUP
-!! SOILDEPTH
-!!
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
+!> @brief initpost_gfs_nems_mpiio() initializes post for run.
+!>
+!> @author Hui-Ya Chuang @date 2007-03-04
+
+!> This routine initializes constants and
+!> variables at the start of GFS model or post
+!> processor run.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2007-03-04 | Hui-Ya Chuang | Initial
+!> 2011-02-07 | Jun Wang | Add grib2 option
+!> 2011-12-14 | Sarah Lu | Add aer option
+!> 2012-01-07 | Sarah Lu | Compute air density
+!> 2012-12-22 | Sarah Lu | Add aerosol zerout option
+!> 2015-03-16 | S. Moorthi | Adding gocart_on option
+!> 2015-03-18 | S. Moorthi | Optimization including threading
+!> 2015-08-17 | S. Moorthi | Add TKE for NEMS/GSM
+!> 2016-03-04 | H Chuang | Add MPI IO option to read GFS nems output
+!> 2016-05-16 | S. Kar | Add computation of omega
+!> 2016-07-21 | S. Moorthi | Convert input upper air data from reduced to full grid and reduce memory in divergence calculatiom
+!> 2016-07-21 | Jun Wang | Change averaged field name with suffix
+!> 2019-07-24 | Li(Kate) Zhang | Merge and update NGAC UPP into FV3-Chem
+!> 2021-03-11 | Bo Cui | Change local arrays to dimension (im,jsta:jend)
+!>
+!> @author Hui-Ya Chuang @date 2007-03-04
SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
@@ -75,8 +55,8 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
avgedir,avgecan,avgetrans,avgesnow,avgprec_cont,avgcprate_cont, &
avisbeamswin,avisdiffswin,airbeamswin,airdiffswin, &
alwoutc,alwtoac,aswoutc,aswtoac,alwinc,aswinc,avgpotevp,snoavg, &
- dustcb,bccb,occb,sulfcb,sscb,dustallcb,ssallcb,dustpm,sspm,pp25cb,pp10cb, &
- ti
+ dustcb,bccb,occb,sulfcb,sscb,dustallcb,ssallcb,dustpm,dustpm10,sspm,pp25cb, &
+ pp10cb,maod,ti
use soil, only: sldpth, sh2o, smc, stc
use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice
! use kinds, only: i_llong
@@ -96,7 +76,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, &
dxval, dyval, truelat2, truelat1, psmapf, cenlat
use nemsio_module_mpi
- use upp_physics, only: fpvsnew
+ use upp_physics, only: fpvsnew, caldiv, calgradps
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
!
@@ -375,7 +355,8 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
print *,me,'max(gdlat)=', maxval(gdlat), &
'max(gdlon)=', maxval(gdlon)
- CALL EXCH(gdlat(1,JSTA_2L))
+ CALL EXCH(gdlat)
+ CALL EXCH(gdlon)
print *,'after call EXCH,me=',me
!$omp parallel do private(i,j,ip1)
@@ -1433,7 +1414,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
dustallcb(1:im,jsta_2l:jend_2u)=dustallcb(1:im,jsta_2l:jend_2u)+ &
(dust(1:im,jsta_2l:jend_2u,ll,1)+dust(1:im,jsta_2l:jend_2u,ll,2)+ &
- dust(1:im,jsta_2l:jend_2u,ll,3)+0.67*dust(1:im,jsta_2l:jend_2u,ll,4))* &
+ dust(1:im,jsta_2l:jend_2u,ll,3)+0.74*dust(1:im,jsta_2l:jend_2u,ll,4))* &
dpres(1:im,jsta_2l:jend_2u,ll)/grav
! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,5)
@@ -1490,7 +1471,8 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
,salt(1:im,jsta_2l:jend_2u,ll,3))
sscb(1:im,jsta_2l:jend_2u)=sscb(1:im,jsta_2l:jend_2u)+ &
- (salt(1:im,jsta_2l:jend_2u,ll,2)+0.75*salt(1:im,jsta_2l:jend_2u,ll,3))* &
+ (salt(1:im,jsta_2l:jend_2u,ll,1)+ &
+ salt(1:im,jsta_2l:jend_2u,ll,2)+0.83*salt(1:im,jsta_2l:jend_2u,ll,3))* &
dpres(1:im,jsta_2l:jend_2u,ll)/grav
! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,3)
@@ -1521,7 +1503,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
ssallcb(1:im,jsta_2l:jend_2u)=ssallcb(1:im,jsta_2l:jend_2u)+ &
(salt(1:im,jsta_2l:jend_2u,ll,1)+salt(1:im,jsta_2l:jend_2u,ll,2)+ &
salt(1:im,jsta_2l:jend_2u,ll,3)+ &
- salt(1:im,jsta_2l:jend_2u,ll,4)*0.83)* &
+ salt(1:im,jsta_2l:jend_2u,ll,4))* &
dpres(1:im,jsta_2l:jend_2u,ll)/grav
! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,5)
@@ -1748,17 +1730,18 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
bccb(i,j) = MAX(bccb(i,j), 0.0)
occb(i,j) = MAX(occb(i,j), 0.0)
sulfcb(i,j) = MAX(sulfcb(i,j), 0.0)
- pp25cb(i,j) = MAX(sulfcb(i,j), 0.0)
- pp10cb(i,j) = MAX(sulfcb(i,j), 0.0)
+ pp25cb(i,j) = MAX(pp25cb(i,j), 0.0)
+ pp10cb(i,j) = MAX(pp10cb(i,j), 0.0)
! PM10 concentration
dusmass(i,j)=(dust(i,j,l,1)+dust(i,j,l,2)+dust(i,j,l,3)+ &
0.74*dust(i,j,l,4)+salt(i,j,l,1)+salt(i,j,l,2)+salt(i,j,l,3)+ &
- salt(i,j,l,4) + &
- salt(i,j,l,5)+soot(i,j,l,1)+soot(i,j,l,2)+waso(i,j,l,1)+ &
+ salt(i,j,l,4) + soot(i,j,l,1)+soot(i,j,l,2)+waso(i,j,l,1)+ &
waso(i,j,l,2) +suso(i,j,l,1)+pp25(i,j,l,1)+pp10(i,j,l,1)) &
*RHOMID(i,j,l) !ug/m3
! PM25 dust and seasalt
dustpm(i,j)=(dust(i,j,l,1)+0.38*dust(i,j,l,2))*RHOMID(i,j,l) !ug/m3
+ dustpm10(i,j)=(dust(i,j,l,1)+dust(i,j,l,2)+dust(i,j,l,3)+ &
+ 0.74*dust(i,j,l,4))*RHOMID(i,j,l) !ug/m3
sspm(i,j)=(salt(i,j,l,1)+salt(i,j,l,2)+ &
0.83*salt(i,j,l,3))*RHOMID(i,j,l) !ug/m3
! PM25 concentration
@@ -3693,43 +3676,6 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
enddo
enddo
-! done with flux file, close it for now
- call nemsio_close(ffile,iret=status)
- deallocate(tmp,recname,reclevtyp,reclev)
-
-
-! Retrieve aer fields if it's listed (GOCART)
- print *, 'iostatus for aer file=', iostatusAER
- if(iostatusAER == 0) then ! start reading aer file
- call nemsio_open(rfile,trim(fileNameAER),'read',mpi_comm_comp &
- ,iret=status)
- if ( Status /= 0 ) then
- print*,'error opening ',fileNameAER, ' Status = ', Status
- endif
- call nemsio_getfilehead(rfile,iret=status,nrec=nrec)
- print*,'nrec for aer file=',nrec
- allocate(recname(nrec),reclevtyp(nrec),reclev(nrec))
- call nemsio_getfilehead(rfile,iret=iret,recname=recname &
- ,reclevtyp=reclevtyp,reclev=reclev)
- if(debugprint)then
- if (me == 0)then
- do i=1,nrec
- print *,'recname,reclevtyp,reclev=',trim(recname(i)),' ', &
- trim(reclevtyp(i)),reclev(i)
- end do
- end if
- end if
-! start reading nemsio aer files using parallel read
- fldsize=(jend-jsta+1)*im
- allocate(tmp(fldsize*nrec))
- print*,'allocate tmp successfully'
- tmp=0.
- call nemsio_denseread(rfile,1,im,jsta,jend,tmp,iret=iret)
- if(iret/=0)then
- print*,"fail to read aer file using mpi io read, stopping"
- stop
- end if
-
! retrieve dust emission fluxes
do K = 1, nbin_du
if ( K == 1) VarName='duem001'
@@ -3737,7 +3683,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
if ( K == 3) VarName='duem003'
if ( K == 4) VarName='duem004'
if ( K == 5) VarName='duem005'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3748,12 +3694,12 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
! retrieve dust sedimentation fluxes
do K = 1, nbin_du
- if ( K == 1) VarName='dust1SD'
- if ( K == 2) VarName='dust2SD'
- if ( K == 3) VarName='dust3SD'
- if ( K == 4) VarName='dust4SD'
- if ( K == 5) VarName='dsut5SD'
- VcoordName='atmos col'
+ if ( K == 1) VarName='dust1sd'
+ if ( K == 2) VarName='dust2sd'
+ if ( K == 3) VarName='dust3sd'
+ if ( K == 4) VarName='dust4sd'
+ if ( K == 5) VarName='dsut5sd'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3769,7 +3715,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
if ( K == 3) VarName='dust3dp'
if ( K == 4) VarName='dust4dp'
if ( K == 5) VarName='dust5dp'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3787,7 +3733,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
if ( K == 3) VarName='dust3wtl'
if ( K == 4) VarName='dust4wtl'
if ( K == 5) VarName='dust5wtl'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3801,7 +3747,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
if ( K == 3) VarName='dust3wtc'
if ( K == 4) VarName='dust4wtc'
if ( K == 5) VarName='dust5wtc'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3816,13 +3762,29 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
if ( K == 3) VarName='ssem003'
if ( K == 4) VarName='ssem004'
if ( K == 5) VarName='ssem005'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
,recname,reclevtyp,reclev,VarName,VcoordName&
,ssem(1,jsta_2l,K))
enddo
+
+! retrieve seasalt emission fluxes
+ do K = 1, nbin_ss
+ if ( K == 1) VarName='seas1sd'
+ if ( K == 2) VarName='seas2sd'
+ if ( K == 3) VarName='seas3sd'
+ if ( K == 4) VarName='seas4sd'
+ if ( K == 5) VarName='seas5sd'
+ VcoordName='sfc'
+ l=1
+ call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
+ ,l,nrec,fldsize,spval,tmp &
+ ,recname,reclevtyp,reclev,VarName,VcoordName&
+ ,sssd(1,jsta_2l,K))
+ enddo
+
! retrieve seasalt dry deposition fluxes
do K = 1, nbin_ss
@@ -3831,7 +3793,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
if ( K == 3) VarName='seas3dp'
if ( K == 4) VarName='seas4dp'
if ( K == 5) VarName='seas5dp'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3846,7 +3808,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
if ( K == 3) VarName='seas3wtl'
if ( K == 4) VarName='seas4wtl'
if ( K == 5) VarName='seas5wtl'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3861,7 +3823,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
if ( K == 3) VarName='seas1wtc'
if ( K == 4) VarName='seas1wtc'
if ( K == 5) VarName='seas1wtc'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3873,7 +3835,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
do K = 1, nbin_bc
if ( K == 1) VarName='bceman'
if ( K == 2) VarName='bcembb'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3885,7 +3847,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
do K = 1, nbin_bc
if ( K == 1) VarName='bc1sd'
if ( K == 2) VarName='bc2sd'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3897,7 +3859,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
do K = 1, nbin_bc
if ( K == 1) VarName='bc1dp'
if ( K == 2) VarName='bc2dp'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3909,7 +3871,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
do K = 1, nbin_bc
if ( K == 1) VarName='bc1wtl'
if ( K == 2) VarName='bc2wtl'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3921,7 +3883,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
do K = 1, nbin_bc
if ( K == 1) VarName='bc1wtc'
if ( K == 2) VarName='bc2wtc'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3933,7 +3895,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
do K = 1, nbin_oc
if ( K == 1) VarName='oceman'
if ( K == 2) VarName='ocembb'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3945,7 +3907,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
do K = 1, nbin_oc
if ( K == 1) VarName='oc1sd'
if ( K == 2) VarName='oc2sd'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3955,9 +3917,9 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
! retrieve oc dry deposition fluxes
do K = 1, nbin_oc
- if ( K == 1) VarName='c1dp'
- if ( K == 2) VarName='c2dp'
- VcoordName='atmos col'
+ if ( K == 1) VarName='oc1dp'
+ if ( K == 2) VarName='oc2dp'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3969,7 +3931,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
do K = 1, nbin_oc
if ( K == 1) VarName='oc1wtl'
if ( K == 2) VarName='oc2wtl'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3981,7 +3943,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
do K = 1, nbin_oc
if ( K == 1) VarName='oc1wtc'
if ( K == 2) VarName='oc2wtc'
- VcoordName='atmos col'
+ VcoordName='atmos sfc'
l=1
call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
,l,nrec,fldsize,spval,tmp &
@@ -3989,8 +3951,20 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
,ocsv(1,jsta_2l,K))
enddo
+! retrieve MIE AOD
+ VarName='maod'
+ VcoordName='sfc'
+ l=1
+ call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
+ ,l,nrec,fldsize,spval,tmp &
+ ,recname,reclevtyp,reclev,VarName,VcoordName&
+ ,maod(1,jsta_2l))
+! done with flux file, close it for now
+ call nemsio_close(ffile,iret=status)
+ deallocate(tmp,recname,reclevtyp,reclev)
+
!lzhang
!! retrieve sfc mass concentration
! VarName='DUSMASS'
@@ -4035,11 +4009,6 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER)
! ,ducmass25)
! if(debugprint)print*,'sample ',VarName,' = ',ducmass25(isa,jsa)
- if (me == 0) print *,'after aer files reading,mype=',me
- call nemsio_close(rfile,iret=status)
- deallocate(tmp,recname,reclevtyp,reclev)
- end if ! end of aer file read
-
! pos east
call collect_loc(gdlat,dummy)
if(me == 0)then
diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f
deleted file mode 100644
index b61732212..000000000
--- a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f
+++ /dev/null
@@ -1,2761 +0,0 @@
-!> @file
-! . . .
-!> SUBPROGRAM: INITPOST_NETCDF INITIALIZE POST FOR RUN
-!! PRGRMMR: Hui-Ya Chuang DATE: 2016-03-04
-!!
-!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND
-!! VARIABLES AT THE START OF GFS MODEL OR POST
-!! PROCESSOR RUN.
-!!
-!! REVISION HISTORY
-!! 2017-08-11 H Chuang start from INITPOST_GFS_NEMS_MPIIO.f
-!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend)
-!!
-!! USAGE: CALL INITPOST_NETCDF
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! NONE
-!! LIBRARY:
-!! COMMON - CTLBLK
-!! LOOKUP
-!! SOILDEPTH
-!!
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
- SUBROUTINE INITPOST_GFS_NETCDF(ncid3d)
-
-
- use netcdf
- use vrbls4d, only: dust, SALT, SUSO, SOOT, WASO, PP25, PP10
- use vrbls3d, only: t, q, uh, vh, pmid, pint, alpint, dpres, zint, zmid, o3, &
- qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, &
- tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, &
- o3vdiff, o3prod, o3tndy, mwpv, unknown, vdiffzacce, zgdrag,cnvctummixing, &
- vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, &
- cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp, &
- wh, qqg, ref_10cm
- use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, &
- cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, &
- tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, radot, sigt4, &
- cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, &
- islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, &
- bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, &
- rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, &
- snopcx, sfcux, sfcvx, sfcuxi, sfcvxi, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, &
- smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, &
- uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, &
- ptoph, pboth, pblcfr, ttoph, runoff, maxtshltr, mintshltr, maxrhshltr, &
- minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, &
- cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa,rel_vort_maxhy1, &
- maxqshltr, minqshltr, acond, sr, u10h, v10h,refd_max, w_up_max, w_dn_max, &
- up_heli_max,up_heli_min,up_heli_max03,up_heli_min03,rel_vort_max01,u10max, v10max, &
- avgedir,avgecan,avgetrans,avgesnow,avgprec_cont,avgcprate_cont,rel_vort_max, &
- avisbeamswin,avisdiffswin,airbeamswin,airdiffswin,refdm10c_max,wspd10max, &
- alwoutc,alwtoac,aswoutc,aswtoac,alwinc,aswinc,avgpotevp,snoavg, &
- ti,aod550,du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550
- use soil, only: sldpth, sh2o, smc, stc
- use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice
- use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, &
- eps => con_eps, epsm1 => con_epsm1
- use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa,pi
- use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, &
- ttblq, rdpq, rdtheq, stheq, the0q, the0
- use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, &
- ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, &
- jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,&
- ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, &
- jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, &
- nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER,rdaod
- use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, &
- dxval, dyval, truelat2, truelat1, psmapf, cenlat,lonstartv, lonlastv, cenlonv, &
- latstartv, latlastv, cenlatv,latstart_r,latlast_r,lonstart_r,lonlast_r
- use upp_physics, only: fpvsnew
-!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- implicit none
-!
-! type(nemsio_gfile) :: nfile,ffile,rfile
- integer,parameter :: nvar2d=48
-! character(nemsio_charkind) :: name2d(nvar2d)
- integer :: nvar3d, numDims
-! character(nemsio_charkind), allocatable :: name3din(:), name3dout(:)
-! character(nemsio_charkind) :: varname,levtype
-!
-! INCLUDE/SET PARAMETERS.
-!
- INCLUDE "mpif.h"
-
-! integer,parameter:: MAXPTS=1000000 ! max im*jm points
-!
-! real,parameter:: con_g =9.80665e+0! gravity
-! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O
-! real,parameter:: con_rd =2.8705e+2 ! gas constant air
-! real,parameter:: con_fvirt =con_rv/con_rd-1.
-! real,parameter:: con_eps =con_rd/con_rv
-! real,parameter:: con_epsm1 =con_rd/con_rv-1
-!
-! This version of INITPOST shows how to initialize, open, read from, and
-! close a NetCDF dataset. In order to change it to read an internal (binary)
-! dataset, do a global replacement of _ncd_ with _int_.
-
- real, parameter :: gravi = 1.0/grav
- character(len=20) :: VarName, VcoordName
- integer :: Status, fldsize, fldst, recn, recn_vvel
- character startdate*19,SysDepInfo*80,cgar*1
- character startdate2(19)*4
-!
-! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK
-! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE.
-!
-! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE
-! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE.
- LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL
-! logical, parameter :: debugprint = .true., zerout = .false.
- logical, parameter :: debugprint = .false., zerout = .false.
- logical :: convert_rad_to_deg=.false.
- CHARACTER*32 varcharval
-! CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC
- CHARACTER*4 RESTHR
- CHARACTER FNAME*255,ENVAR*50
- INTEGER IDATE(8),JDATE(8),JPDS(200),JGDS(200),KPDS(200),KGDS(200)
-! LOGICAL*1 LB(IM,JM)
-!
-! INCLUDE COMMON BLOCKS.
-!
-! DECLARE VARIABLES.
-!
-! REAL fhour
-! integer nfhour ! forecast hour from nems io file
- integer fhzero !bucket
- real dtp !physics time step
- REAL RINC(5)
-
-! REAL FI(IM,JM,2)
- REAL DUMMY(IM,JM)
-
-!jw
- integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, &
- I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, &
- nframed2,iunitd3d,ierr,idum,iret,nrec,idrt
- integer ncid3d,ncid2d,varid,nhcas
- real TSTART,TLMH,TSPH,ES,FACT,soilayert,soilayerb,zhour,dum, &
- tvll,pmll,tv, tx1, tx2
-
- character*20,allocatable :: recname(:)
- integer, allocatable :: reclev(:), kmsk(:,:)
- real, allocatable :: glat1d(:), glon1d(:), qstl(:)
- real, allocatable :: wrk1(:,:), wrk2(:,:)
- real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), &
- qs2d(:,:), cw2d(:,:), cfr2d(:,:)
- real(kind=4),allocatable :: vcoord4(:,:,:)
- real, dimension(lm+1) :: ak5, bk5
- real*8, allocatable :: pm2d(:,:), pi2d(:,:)
- real, allocatable :: tmp(:)
- real :: buf(im,jsta_2l:jend_2u)
- real :: buf3d(im,jsta_2l:jend_2u,lm)
-
-! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) &
-! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u)
-
- real LAT
- integer isa, jsa, latghf, jtem, idvc, idsl, nvcoord, ip1, nn, npass
-
- integer, parameter :: npass2=5, npass3=30
- real, parameter :: third=1.0/3.0
- INTEGER, DIMENSION(2) :: ij4min, ij4max
- REAL :: omgmin, omgmax
- real, allocatable :: d2d(:,:), u2d(:,:), v2d(:,:), omga2d(:,:)
- REAL, ALLOCATABLE :: ps2d(:,:),psx2d(:,:),psy2d(:,:)
- real, allocatable :: div3d(:,:,:)
- real(kind=4),allocatable :: vcrd(:,:)
- real :: dum_const
-
-!***********************************************************************
-! START INIT HERE.
-!
- WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NETCDF'
- WRITE(6,*)'me=',me, &
- 'jsta_2l=',jsta_2l,'jend_2u=', &
- jend_2u,'im=',im
-!
- isa = im / 2
- jsa = (jsta+jend) / 2
-
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- buf(i,j) = spval
- enddo
- enddo
-
- Status=nf90_get_att(ncid3d,nf90_global,'ak',ak5)
- if(Status/=0)then
- print*,'ak not found; assigning missing value'
- ak5=spval
- else
- if(me==0)print*,'ak5= ',ak5
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'idrt',idrt)
- if(Status/=0)then
- print*,'idrt not in netcdf file,reading grid'
- Status=nf90_get_att(ncid3d,nf90_global,'grid',varcharval)
- if(Status/=0)then
- print*,'idrt and grid not in netcdf file, set default to latlon'
- idrt=0
- MAPTYPE=0
- else
- if(trim(varcharval)=='rotated_latlon')then
- MAPTYPE=207
- idrt=207
- Status=nf90_get_att(ncid3d,nf90_global,'cen_lon',dum_const)
- if(Status/=0)then
- print*,'cen_lon not found; assigning missing value'
- cenlon=spval
- else
- if(dum_const<0.)then
- cenlon=nint((dum_const+360.)*gdsdegr)
- else
- cenlon=dum_const*gdsdegr
- end if
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'cen_lat',dum_const)
- if(Status/=0)then
- print*,'cen_lat not found; assigning missing value'
- cenlat=spval
- else
- cenlat=dum_const*gdsdegr
- end if
-
- Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const)
- if(Status/=0)then
- print*,'lonstart_r not found; assigning missing value'
- lonstart_r=spval
- else
- if(dum_const<0.)then
- lonstart_r=nint((dum_const+360.)*gdsdegr)
- else
- lonstart_r=dum_const*gdsdegr
- end if
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const)
- if(Status/=0)then
- print*,'latstart_r not found; assigning missing value'
- latstart_r=spval
- else
- latstart_r=dum_const*gdsdegr
- end if
-
- Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const)
- if(Status/=0)then
- print*,'lonlast_r not found; assigning missing value'
- lonlast_r=spval
- else
- if(dum_const<0.)then
- lonlast_r=nint((dum_const+360.)*gdsdegr)
- else
- lonlast_r=dum_const*gdsdegr
- end if
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const)
- if(Status/=0)then
- print*,'latlast_r not found; assigning missing value'
- latlast_r=spval
- else
- latlast_r=dum_const*gdsdegr
- end if
-
- Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const)
- if(Status/=0)then
- print*,'dlmd not found; assigning missing value'
- dxval=spval
- else
- dxval=dum_const*gdsdegr
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const)
- if(Status/=0)then
- print*,'dphd not found; assigning missing value'
- dyval=spval
- else
- dyval=dum_const*gdsdegr
- end if
-
- print*,'lonstart,latstart,cenlon,cenlat,dyval,dxval', &
- lonstart,latstart,cenlon,cenlat,dyval,dxval
-
-! Jili Dong add support for regular lat lon (2019/03/22) start
- else if(trim(varcharval)=='latlon')then
- MAPTYPE=0
- idrt=0
-
- Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const)
- if(Status/=0)then
- print*,'lonstart not found; assigning missing value'
- lonstart=spval
- else
- if(dum_const<0.)then
- lonstart=nint((dum_const+360.)*gdsdegr)
- else
- lonstart=dum_const*gdsdegr
- end if
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const)
- if(Status/=0)then
- print*,'latstart not found; assigning missing value'
- latstart=spval
- else
- latstart=dum_const*gdsdegr
- end if
-
- Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const)
- if(Status/=0)then
- print*,'lonlast not found; assigning missing value'
- lonlast=spval
- else
- if(dum_const<0.)then
- lonlast=nint((dum_const+360.)*gdsdegr)
- else
- lonlast=dum_const*gdsdegr
- end if
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const)
- if(Status/=0)then
- print*,'latlast not found; assigning missing value'
- latlast=spval
- else
- latlast=dum_const*gdsdegr
- end if
-
- Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const)
- if(Status/=0)then
- print*,'dlmd not found; assigning missing value'
- dxval=spval
- else
- dxval=dum_const*gdsdegr
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const)
- if(Status/=0)then
- print*,'dphd not found; assigning missing value'
- dyval=spval
- else
- dyval=dum_const*gdsdegr
- end if
-
- print*,'lonstart,latstart,dyval,dxval', &
- lonstart,lonlast,latstart,latlast,dyval,dxval
-
-! Jili Dong add support for regular lat lon (2019/03/22) end
-
- else if(trim(varcharval)=='gaussian')then
- MAPTYPE=4
- idrt=4
- else ! setting default maptype
- MAPTYPE=0
- idrt=0
- end if
- end if !end reading grid
- end if !end reading idrt
- if(me==0)print*,'idrt MAPTYPE= ',idrt,MAPTYPE
-! STEP 1. READ MODEL OUTPUT FILE
-!
-!
-!***
-!
-! LMH and LMV always = LM for sigma-type vert coord
-
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i = 1, im
- LMV(i,j) = lm
- LMH(i,j) = lm
- end do
- end do
-
-! HTM VTM all 1 for sigma-type vert coord
-
-!$omp parallel do private(i,j,l)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- HTM (i,j,l) = 1.0
- VTM (i,j,l) = 1.0
- end do
- end do
- end do
-
- Status=nf90_get_att(ncid3d,nf90_global,'nhcas',nhcas)
- if(Status/=0)then
- print*,'nhcas not in netcdf file, set default to nonhydro'
- nhcas=0
- end if
- if(me==0)print*,'nhcas= ',nhcas
- if (nhcas == 0 ) then !non-hydrostatic case
- nrec=15
- allocate (recname(nrec))
- recname=[character(len=20) :: 'ugrd','vgrd','spfh','tmp','o3mr', &
- 'presnh','dzdt', 'clwmr','dpres', &
- 'delz','icmr','rwmr', &
- 'snmr','grle','cld_amt']
- else
- nrec=8
- allocate (recname(nrec))
- recname=[character(len=20) :: 'ugrd','vgrd','tmp','spfh','o3mr', &
- 'hypres', 'clwmr','dpres']
- endif
-
-! write(0,*)'nrec=',nrec
- !allocate(recname(nrec),reclevtyp(nrec),reclev(nrec))
- allocate(glat1d(jm),glon1d(im))
- allocate(vcoord4(lm+1,3,2))
-
-! hardwire idate for now
-! idate=(/2017,08,07,00,0,0,0,0/)
-! get cycle start time
- Status=nf90_inq_varid(ncid3d,'time',varid)
- if(Status/=0)then
- print*,'time not in netcdf file, stopping'
- STOP 1
- else
- Status=nf90_get_att(ncid3d,varid,'units',varcharval)
- if(Status/=0)then
- print*,'time unit not available'
- else
- print*,'time unit read from netcdf file= ',varcharval
-! assume use hours as unit
-! idate_loc=index(varcharval,'since')+6
- read(varcharval,101)idate(1),idate(2),idate(3),idate(4),idate(5)
- end if
-! Status=nf90_inquire_dimension(ncid3d,varid,len=ntimes)
-! allocate(fhours(ntimes))
-! status = nf90_inq_varid(ncid3d,varid,fhours)
-! Status=nf90_get_var(ncid3d,varid,nfhour,start=(/1/), &
-! count=(/1/))
-! if(Status/=0)then
-! print*,'forecast hour not in netcdf file, stopping'
-! STOP 1
-! end if
- end if
- 101 format(T13,i4,1x,i2,1x,i2,1x,i2,1x,i2)
- print*,'idate= ',idate(1:5)
-! get longitude
- Status=nf90_inq_varid(ncid3d,'grid_xt',varid)
- Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims)
- if(debugprint)print*,'number of dim for gdlon ',numDims
- if(numDims==1)then
- Status=nf90_get_var(ncid3d,varid,glon1d)
- do j=jsta,jend
- do i=1,im
- gdlon(i,j) = real(glon1d(i),kind=4)
- end do
- end do
- lonstart = nint(glon1d(1)*gdsdegr)
- lonlast = nint(glon1d(im)*gdsdegr)
- dxval = nint(abs(glon1d(1)-glon1d(2))*gdsdegr)
- else if(numDims==2)then
- Status=nf90_get_var(ncid3d,varid,dummy)
- if(maxval(abs(dummy))<2.0*pi)convert_rad_to_deg=.true.
- if(convert_rad_to_deg)then
- do j=jsta,jend
- do i=1,im
- gdlon(i,j) = real(dummy(i,j),kind=4)*180./pi
- end do
- end do
- else
- do j=jsta,jend
- do i=1,im
- gdlon(i,j) = real(dummy(i,j),kind=4)
- end do
- end do
- end if
- if(convert_rad_to_deg)then
- lonstart = nint(dummy(1,1)*gdsdegr)*180./pi
- lonlast = nint(dummy(im,jm)*gdsdegr)*180./pi
- dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr)*180./pi
- else
- lonstart = nint(dummy(1,1)*gdsdegr)
- lonlast = nint(dummy(im,jm)*gdsdegr)
- dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr)
- end if
-
-! Jili Dong add support for regular lat lon (2019/03/22) start
- if (MAPTYPE == 0) then
- if(lonstart<0.)then
- lonstart=lonstart+360.*gdsdegr
- end if
- if(lonlast<0.)then
- lonlast=lonlast+360.*gdsdegr
- end if
- end if
-! Jili Dong add support for regular lat lon (2019/03/22) end
-
- end if
- print*,'lonstart,lonlast,dxval ',lonstart,lonlast,dxval
-! get latitude
- Status=nf90_inq_varid(ncid3d,'grid_yt',varid)
- Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims)
- if(debugprint)print*,'number of dim for gdlat ',numDims
- if(numDims==1)then
- Status=nf90_get_var(ncid3d,varid,glat1d)
- do j=jsta,jend
- do i=1,im
- gdlat(i,j) = real(glat1d(j),kind=4)
- end do
- end do
- latstart = nint(glat1d(1)*gdsdegr)
- latlast = nint(glat1d(jm)*gdsdegr)
- dyval = nint(abs(glat1d(1)-glat1d(2))*gdsdegr)
- else if(numDims==2)then
- Status=nf90_get_var(ncid3d,varid,dummy)
- if(maxval(abs(dummy))1.0e5)print*,'bad dpres ',i,j,dpres(i,j,l)
-!make sure delz is positive
-! if(dpres(i,j,l)/=spval .and. t(i,j,l)/=spval .and. &
-! q(i,j,l)/=spval .and. buf3d(i,j,l)/=spval)then
-! pmid(i,j,l)=rgas*dpres(i,j,l)* &
-! t(i,j,l)*(q(i,j,l)*fv+1.0)/grav/abs(buf3d(i,j,l))
-! else
-! pmid(i,j,l)=spval
-! end if
-! dong add missing value
- if (wh(i,j,l) < spval) then
- omga(i,j,l)=(-1.)*wh(i,j,l)*dpres(i,j,l)/abs(buf3d(i,j,l))
- else
- omga(i,j,l) = spval
- end if
-! if(t(i,j,l)>1000.)print*,'bad T ',t(i,j,l)
- enddo
- enddo
- enddo
- call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(11) &
- ,lm,qqi(1,jsta_2l,1))
- call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(12) &
- ,lm,qqr(1,jsta_2l,1))
- call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(13) &
- ,lm,qqs(1,jsta_2l,1))
- call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(14) &
- ,lm,qqg(1,jsta_2l,1))
- call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(15) &
- ,lm,cfr(1,jsta_2l,1))
-! calculate CWM from FV3 output
- do l=1,lm
- do j=jsta,jend
- do i=1,im
- cwm(i,j,l)=qqg(i,j,l)+qqs(i,j,l)+qqr(i,j,l)+qqi(i,j,l)+qqw(i,j,l)
- enddo
- enddo
- if(debugprint)print*,'sample l,t,q,u,v,w,= ',isa,jsa,l &
- ,t(isa,jsa,l),q(isa,jsa,l),uh(isa,jsa,l),vh(isa,jsa,l) &
- ,wh(isa,jsa,l)
- if(debugprint)print*,'sample l cwm for FV3',l, &
- cwm(isa,jsa,l)
- end do
-! max hourly updraft velocity
-! VarName='upvvelmax'
-! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,w_up_max)
-! if(debugprint)print*,'sample ',VarName,' = ',w_up_max(isa,jsa)
-
-! max hourly downdraft velocity
-! VarName='dnvvelmax'
-! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,w_dn_max)
-! if(debugprint)print*,'sample ',VarName,' = ',w_dn_max(isa,jsa)
-! max hourly updraft helicity
-! VarName='uhmax25'
-! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_max)
-! if(debugprint)print*,'sample ',VarName,' = ',up_heli_max(isa,jsa)
-! min hourly updraft helicity
-! VarName='uhmin25'
-! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_min)
-! if(debugprint)print*,'sample ',VarName,' = ',up_heli_min(isa,jsa)
-! max hourly 0-3km updraft helicity
-! VarName='uhmax03'
-! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_max03)
-! if(debugprint)print*,'sample ',VarName,' = ',up_heli_max03(isa,jsa)
-! min hourly 0-3km updraft helicity
-! VarName='uhmin03'
-! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_min03)
-! if(debugprint)print*,'sample ',VarName,' = ',up_heli_min03(isa,jsa)
-
-! max 0-1km relative vorticity max
-! VarName='maxvort01'
-! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_max01)
-! if(debugprint)print*,'sample ',VarName,' = ',rel_vort_max01(isa,jsa)
-! max 0-2km relative vorticity max
-! VarName='maxvort02'
-! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_max)
-! if(debugprint)print*,'sample ',VarName,' =',rel_vort_max(isa,jsa)
-! max hybrid lev 1 relative vorticity max
-! VarName='maxvorthy1'
-! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_maxhy1)
-! if(debugprint)print*,'sample ',VarName,' =',rel_vort_maxhy1(isa,jsa)
-! surface pressure
- VarName='pressfc'
- call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,pint(1,jsta_2l,lp1))
- do j=jsta,jend
- do i=1,im
-! if(pint(i,j,lp1)>1.0E6 .or. pint(1,jsta_2l,lp1)<50000.) &
-! print*,'bad psfc ',i,j,pint(i,j,lp1)
- end do
- end do
- if(debugprint)print*,'sample ',VarName,' =',pint(isa,jsa,lp1)
-
- pt = ak5(1)
-
- do j=jsta,jend
- do i=1,im
- pint(i,j,1)= pt
- end do
- end do
-
- do l=2,lp1
- do j=jsta,jend
- do i=1,im
- pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1)
- enddo
- enddo
-! if (me == 0) print*,'sample model pint,pmid' ,ii,jj,l &
-! ,pint(ii,jj,l),pmid(ii,jj,l)
- end do
-
-!compute pmid from averaged two layer pint
- do l=lm,1,-1
- do j=jsta,jend
- do i=1,im
- pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1))
- enddo
- enddo
- enddo
-
-! do l=lm,1,-1
-! do j=jsta,jend
-! do i=1,im
-! if(pint(i,j,l+1)/=spval .and. dpres(i,j,l)/=spval)then
-! pint(i,j,l)=pint(i,j,l+1)-dpres(i,j,l)
-! else
-! pint(i,j,l)=spval
-! end if
-! end do
-! end do
-! print*,'sample pint= ',isa,jsa,l,pint(isa,jsa,l)
-! end do
-
-! surface height from FV3
-! dong set missing value for zint
-! zint=spval
- VarName='hgtsfc'
- call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
- ,zint(1,jsta_2l,lp1))
- if(debugprint)print*,'sample ',VarName,' =',zint(isa,jsa,lp1)
- do j=jsta,jend
- do i=1,im
- if (zint(i,j,lp1) /= spval) then
- fis(i,j) = zint(i,j,lp1) * grav
- else
- fis(i,j) = spval
- endif
- enddo
- enddo
-
- do l=lm,1,-1
- do j=jsta,jend
- do i=1,im
- if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then
-!make sure delz is positive
- zint(i,j,l)=zint(i,j,l+1)+abs(buf3d(i,j,l))
-! if(zint(i,j,l)>1.0E6)print*,'bad H ',i,j,l,zint(i,j,l)
- else
- zint(i,j,l)=spval
- end if
- end do
- end do
- print*,'sample zint= ',isa,jsa,l,zint(isa,jsa,l)
- end do
-
- do l=lp1,1,-1
- do j=jsta,jend
- do i=1,im
- alpint(i,j,l)=log(pint(i,j,l))
- end do
- end do
- end do
-
- do l=lm,1,-1
- do j=jsta,jend
- do i=1,im
- if(zint(i,j,l+1)/=spval .and. zint(i,j,l)/=spval &
- .and. pmid(i,j,l)/=spval)then
- zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* &
- (log(pmid(i,j,l))-alpint(i,j,l+1))/ &
- (alpint(i,j,l)-alpint(i,j,l+1))
- if(zmid(i,j,l)>1.0E6)print*,'bad Hmid ',i,j,l,zmid(i,j,l)
- else
- zmid(i,j,l)=spval
- endif
- end do
- end do
- end do
-
-
- pt = ak5(1)
-
-! else
-! do l=2,lm
-!!$omp parallel do private(i,j)
-! do j=jsta,jend
-! do i=1,im
-! pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1)
-! enddo
-! enddo
-! if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l)
-! end do
-! endif
-!
-
- deallocate (vcoord4)
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-!
-
-! done with 3d file, close it for now
- Status=nf90_close(ncid3d)
- deallocate(recname)
-
-! open flux file
- Status = nf90_open(trim(fileNameFlux),NF90_NOWRITE, ncid2d)
-
- if ( Status /= 0 ) then
- print*,'error opening ',fileNameFlux, ' Status = ', Status
- print*,'skip reading of flux file'
- endif
-
-! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD
- VarName='IVEGSRC'
- Status=nf90_get_att(ncid2d,nf90_global,'IVEGSRC',IVEGSRC)
- if (Status /= 0) then
- print*,VarName,' not found-Assigned 1 for IGBP as default'
- IVEGSRC=1
- end if
- if (me == 0) print*,'IVEGSRC= ',IVEGSRC
-
-! set novegtype based on vegetation classification
- if(ivegsrc==2)then
- novegtype=13
- else if(ivegsrc==1)then
- novegtype=20
- else if(ivegsrc==0)then
- novegtype=24
- end if
- if (me == 0) print*,'novegtype= ',novegtype
-
- Status=nf90_get_att(ncid2d,nf90_global,'imp_physics',imp_physics)
- if (Status /= 0) then
- print*,VarName,' not found-Assigned 11 GFDL as default'
- imp_physics=11
- end if
- if (me == 0) print*,'MP_PHYSICS= ',imp_physics
-!
- Status=nf90_get_att(ncid2d,nf90_global,'fhzero',fhzero)
- if (Status /= 0) then
- print*,VarName,' not found-Assigned 3 hours as default'
- fhzero=3
- end if
- if (me == 0) print*,'fhzero= ',fhzero
-!
- Status=nf90_get_att(ncid2d,nf90_global,'dtp',dtp)
- if (Status /= 0) then
- print*,VarName,' not found-Assigned 90s as default'
- dtp=90
- end if
- if (me == 0) print*,'dtp= ',dtp
-! Initializes constants for Ferrier microphysics
- if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95) then
- CALL MICROINIT(imp_physics)
- end if
-
-! Chuang: zhour is when GFS empties bucket last so using this
-! to compute buket will result in changing bucket with forecast time.
-! set default bucket for now
-
-! call nemsio_getheadvar(ffile,'zhour',zhour,iret=iret)
-! if(iret == 0) then
-! tprec = 1.0*ifhr-zhour
-! tclod = tprec
-! trdlw = tprec
-! trdsw = tprec
-! tsrfc = tprec
-! tmaxmin = tprec
-! td3d = tprec
-! print*,'tprec from flux file header= ',tprec
-! else
-! print*,'Error reading accumulation bucket from flux file', &
-! 'header - will try to read from env variable FHZER'
-! CALL GETENV('FHZER',ENVAR)
-! read(ENVAR, '(I2)')idum
-! tprec = idum*1.0
-! tclod = tprec
-! trdlw = tprec
-! trdsw = tprec
-! tsrfc = tprec
-! tmaxmin = tprec
-! td3d = tprec
-! print*,'TPREC from FHZER= ',tprec
-! end if
-
-
- tprec = float(fhzero)
- if(ifhr>240)tprec=12.
- tclod = tprec
- trdlw = tprec
- trdsw = tprec
- tsrfc = tprec
- tmaxmin = tprec
- td3d = tprec
- print*,'tprec = ',tprec
-
-
-! start reading 2d netcdf file
-! surface pressure
-! VarName='pressfc'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
-! ,pint(1,jsta_2l,lp1))
-! if(debugprint)print*,'sample ',VarName,' =',pint(isa,jsa,lp1)
-! do l=lm,1,-1
-! do j=jsta,jend
-! do i=1,im
-! pint(i,j,l)=pint(i,j,l+1)-dpres(i,j,l)
-! if(pint(i,j,l)>1.0E6)print*,'bad P ',i,j,l,pint(i,j,l) &
-! ,pint(i,j,l+1),dpres(i,j,l)
-! end do
-! end do
-! print*,'sample pint= ',isa,jsa,l,pint(isa,jsa,l)
-! end do
-! surface height from FV3 already multiplied by G
-! VarName='orog'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,fis)
-! if(debugprint)print*,'sample ',VarName,' =',fis(isa,jsa)
-! do j=jsta,jend
-! do i=1,im
-! if (fis(i,j) /= spval) then
-! zint(i,j,lp1) = fis(i,j)
-! fis(i,j) = fis(i,j) * grav
-! else
-! zint(i,j,lp1) = spval
-! fis(i,j) = spval
-! endif
-! enddo
-! enddo
-
-! do l=lm,1,-1
-! do j=jsta,jend
-! do i=1,im
-! if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then
-! zint(i,j,l)=zint(i,j,l+1)+buf3d(i,j,l)
-! if(zint(i,j,l)>1.0E6)print*,'bad H ',i,j,l,zint(i,j,l)
-! else
-! zint(i,j,l)=spval
-! end if
-! end do
-! end do
-! print*,'sample zint= ',isa,jsa,l,zint(isa,jsa,l)
-! end do
-
-! Per communication with Fanglin, P from model in not monotonic
-! so compute P using ak and bk for now Sep. 2017
-! do l=lm,1,-1
-!!!$omp parallel do private(i,j)
-! do j=jsta,jend
-! do i=1,im
-! pint(i,j,l) = ak5(lm+2-l) + bk5(lm+2-l)*pint(i,j,lp1)
-! pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) ! for now -
-! enddo
-! enddo
-! print*,'sample pint,pmid' &
-! ,l,pint(isa,jsa,l),pmid(isa,jsa,l)
-! enddo
-
-! allocate(wrk1(im,jsta:jend),wrk2(im,jsta:jend))
-! do j=jsta,jend
-! do i=1,im
-! pd(i,j) = spval ! GFS does not output PD
-! pint(i,j,1) = PT
-! alpint(i,j,lp1) = log(pint(i,j,lp1))
-! wrk1(i,j) = log(PMID(I,J,LM))
-! wrk2(i,j) = T(I,J,LM)*(Q(I,J,LM)*fv+1.0)
-! FI(I,J,1) = FIS(I,J) &
-! + wrk2(i,j)*rgas*(ALPINT(I,J,Lp1)-wrk1(i,j))
-! ZMID(I,J,LM) = FI(I,J,1) * gravi
-! end do
-! end do
-
-! SECOND, INTEGRATE HEIGHT HYDROSTATICLY, GFS integrate height on
-! mid-layer
-
-! DO L=LM,2,-1 ! omit computing model top height
-! ll = l - 1
-! do j = jsta, jend
-! do i = 1, im
-! alpint(i,j,l) = log(pint(i,j,l))
-! tvll = T(I,J,LL)*(Q(I,J,LL)*fv+1.0)
-! pmll = log(PMID(I,J,LL))
-
-! FI(I,J,2) = FI(I,J,1) + (0.5*rgas)*(wrk2(i,j)+tvll) &
-! * (wrk1(i,j)-pmll)
-! ZMID(I,J,LL) = FI(I,J,2) * gravi
-!
-! FACT = (ALPINT(I,J,L)-wrk1(i,j)) / (pmll-wrk1(i,j))
-! ZINT(I,J,L) = ZMID(I,J,L) +(ZMID(I,J,LL)-ZMID(I,J,L))*FACT
-! FI(I,J,1) = FI(I,J,2)
-! wrk1(i,J) = pmll
-! wrk2(i,j) = tvll
-! ENDDO
-! ENDDO
-
-! print*,'L ZINT= ',l,zint(isa,jsa,l),ZMID(isa,jsa,l)
-! ,'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)), &
-! 'pmid(l-1)=',LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L), &
-! 'zmid(l-1)=',ZMID(Ii,Jj,L-1)
-! ENDDO
-! deallocate(wrk1,wrk2)
-
-! do l=lp1,2,-1
-! do j=jsta,jend
-! do i=1,im
-! alpint(i,j,l)=log(pint(i,j,l))
-! end do
-! end do
-! end do
-
-! do l=lm,2,-1
-! do j=jsta,jend
-! do i=1,im
-! zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* &
-! (log(pmid(i,j,l))-alpint(i,j,l+1))/ &
-! (alpint(i,j,l)-alpint(i,j,l+1))
-! if(zmid(i,j,l)>1.0E6)print*,'bad Hmid ',i,j,l,zmid(i,j,l)
-! end do
-! end do
-! end do
-
-! VarName='refl_10cm'
-! do l=1,lm
-! call read_netcdf_3d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName &
-! ,lm,REF_10CM(1,jsta_2l,1))
-! if(debugprint)print*,'sample ',VarName,'isa,jsa,l =' &
-! ,REF_10CM(isa,jsa,l),isa,jsa,l
-! enddo
-!Set REF_10CM as missning since gfs doesn't ouput it
- do l=1,lm
- do j=jsta,jend
- do i=1,im
- REF_10CM(i,j,l)=spval
- enddo
- enddo
- enddo
-
- VarName='land'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sm)
- if(debugprint)print*,'sample ',VarName,' =',sm(im/2,(jsta+jend)/2)
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j)
- enddo
- enddo
-
-! sea ice mask
-
- VarName = 'icec'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sice)
- if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa)
-
-! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea
-! mask=0
-! GFS flux files have land points with non-zero sea ice, per Iredell,
-! these
-! points have sea ice changed to zero, i.e., trust land mask more than
-! sea ice
-! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0
- enddo
- enddo
-
-
-! PBL height using nemsio
- VarName = 'hpbl'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pblh)
- if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa)
-
-! frictional velocity using nemsio
- VarName='fricv'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ustar)
-! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa)
-
-! roughness length using getgb
- VarName='sfcr'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,z0)
-! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa)
-
-! sfc exchange coeff
- VarName='sfexc'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,SFCEXC)
-
-! aerodynamic conductance
- VarName='acond'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,acond)
- if(debugprint)print*,'sample ',VarName,' = ',acond(isa,jsa)
-! mid day avg albedo
- VarName='albdo_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgalbedo)
- if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa)
- do j=jsta,jend
- do i=1,im
- if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01
- enddo
- enddo
-
-! surface potential T using getgb
- VarName='tmpsfc'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ths)
-
-! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (ths(i,j) /= spval) then
-! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1)
- ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa
- endif
- QS(i,j) = SPVAL ! GFS does not have surface specific humidity
- twbs(i,j) = SPVAL ! GFS does not have inst sensible heat flux
- qwbs(i,j) = SPVAL ! GFS does not have inst latent heat flux
-!assign sst
- if (sm(i,j) /= 0.0) then
- sst(i,j) = ths(i,j) * (pint(i,j,lp1)/p1000)**capa
- else
- sst(i,j) = spval
- endif
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa)
-
-
-! GFS does not have time step and physics time step, make up ones since they
-! are not really used anyway
-! NPHS=1.
-! DT=90.
-! DTQ2 = DT * NPHS !MEB need to get physics DT
- DTQ2 = DTP !MEB need to get physics DT
- NPHS=1
- DT = DTQ2/NPHS !MEB need to get DT
- TSPH = 3600./DT
-
-! convective precip in m per physics time step using getgb
-! read 3 hour bucket
- VarName='cpratb_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcprate)
-! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001)
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa)
-
-! print*,'maxval CPRATE: ', maxval(CPRATE)
-
-! read continuous bucket
- VarName='cprat_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcprate_cont)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcprate_cont(i,j) /= spval) avgcprate_cont(i,j) = &
- avgcprate_cont(i,j) * (dtq2*0.001)
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',avgcprate_cont(isa,jsa)
-
-! print*,'maxval CPRATE: ', maxval(CPRATE)
-
-! precip rate in m per physics time step using getgb
- VarName='prateb_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgprec)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if(avgprec(i,j) /= spval)avgprec(i,j)=avgprec(i,j)*(dtq2*0.001)
- enddo
- enddo
-
- if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa)
-
-! prec = avgprec !set avg cprate to inst one to derive other fields
-
- VarName='prate_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgprec_cont)
-! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgprec_cont(i,j) /=spval)avgprec_cont(i,j)=avgprec_cont(i,j) &
- * (dtq2*0.001)
- enddo
- enddo
-
- if(debugprint)print*,'sample ',VarName,' = ',avgprec_cont(isa,jsa)
-! precip rate in m per physics time step
- VarName='tprcp'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,prec)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (prec(i,j) /= spval) prec(i,j)=prec(i,j)* (dtq2*0.001) &
- * 1000. / dtp
- enddo
- enddo
-
-! convective precip rate in m per physics time step
- VarName='cnvprcp'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cprate)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (cprate(i,j) /= spval) then
- cprate(i,j) = max(0.,cprate(i,j)) * (dtq2*0.001) &
- * 1000. / dtp
- else
- cprate(i,j) = 0.
- endif
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',cprate(isa,jsa)
-
-! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f
-
-! max hourly 1-km agl reflectivity
-! VarName='refdmax'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refd_max)
-! if(debugprint)print*,'sample ',VarName,' = ',refd_max(isa,jsa)
-! max hourly -10C reflectivity
-! VarName='refdmax263k'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refdm10c_max)
-! if(debugprint)print*,'sample ',VarName,' = ',refdm10c_max(isa,jsa)
-
-! max hourly u comp of 10m agl wind
-! VarName='u10max'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,u10max)
-! if(debugprint)print*,'sample ',VarName,' = ',u10max(isa,jsa)
-! max hourly v comp of 10m agl wind
-! VarName='v10max'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,v10max)
-! if(debugprint)print*,'sample ',VarName,' = ',v10max(isa,jsa)
-! max hourly 10m agl wind speed
-! VarName='spd10max'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,wspd10max)
-! if(debugprint)print*,'sample ',VarName,' = ',wspd10max(isa,jsa)
-
-
-! 2m T using nemsio
- VarName='tmp2m'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,tshltr)
- if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa)
-
-! inst snow water eqivalent using nemsio
- VarName='weasd'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sno)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j)==0.) sno(i,j) = spval
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa)
-
-! ave snow cover
- VarName='snowc_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,snoavg)
-! snow cover is multipled by 100 in SURFCE before writing it out
- do j=jsta,jend
- do i=1,im
- if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j)=spval
- if(snoavg(i,j)/=spval)snoavg(i,j)=snoavg(i,j)/100.
- end do
- end do
-
-! snow depth in mm using nemsio
- VarName='snod'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,si)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval
- if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0
- CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency
- lspa(i,j) = spval ! GFS does not have similated precip
- TH10(i,j) = SPVAL ! GFS does not have 10 m theta
- TH10(i,j) = SPVAL ! GFS does not have 10 m theta
- Q10(i,j) = SPVAL ! GFS does not have 10 m humidity
- ALBASE(i,j) = SPVAL ! GFS does not have snow free albedo
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa)
-
-! 2m T using nemsio
- VarName='tmp2m'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,tshltr)
- if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa)
-
-! GFS does not have 2m pres, estimate it, also convert t to theta
- Do j=jsta,jend
- Do i=1,im
- PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j))
- tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta
-! if (j == jm/2 .and. mod(i,50) == 0)
-! + print*,'sample 2m T and P after scatter= '
-! + ,i,j,tshltr(i,j),pshltr(i,j)
- end do
- end do
-
-! 2m specific humidity using nemsio
- VarName='spfh2m'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,qshltr)
- if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa)
-
-! mid day avg albedo in fraction using nemsio
-! VarName='albdosfc'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgalbedo)
-!! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction
-!!$omp parallel do private(i,j)
-! do j=jsta,jend
-! do i=1,im
-! if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01
-! enddo
-! enddo
-! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa)
-
-! time averaged column cloud fractionusing nemsio
- VarName='tcdc_aveclm'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgtcdc)
-! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa)
-
-! GFS probably does not use zenith angle
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- Czen(i,j) = spval
- CZMEAN(i,j) = SPVAL
- enddo
- enddo
-
-! maximum snow albedo in fraction using nemsio
- VarName='snoalb'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,mxsnal)
-! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa)
-
-! GFS probably does not use sigt4, set it to sig*t^4
-!$omp parallel do private(i,j,tlmh)
- Do j=jsta,jend
- Do i=1,im
- TLMH = T(I,J,LM) * T(I,J,LM)
- Sigt4(i,j) = 5.67E-8 * TLMH * TLMH
- End do
- End do
-
-! TG is not used, skip it for now
-
-! GFS does not have inst cloud fraction for high, middle, and low cloud
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- cfrach(i,j) = spval
- cfracl(i,j) = spval
- cfracm(i,j) = spval
- enddo
- enddo
-
-! ave high cloud fraction using nemsio
- VarName='tcdc_avehcl'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfrach)
-! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa)
-
-! ave low cloud fraction using nemsio
- VarName='tcdc_avelcl'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfracl)
-! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa)
-
-! ave middle cloud fraction using nemsio
- VarName='tcdc_avemcl'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfracm)
-! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa)
-
-! inst convective cloud fraction using nemsio
- VarName='tcdccnvcl'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cnvcfr)
-! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa)
-
-! slope type using nemsio
- VarName='sltyp'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf)
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- if (buf(i,j) < spval) then
- islope(i,j) = nint(buf(i,j))
- else
- islope(i,j) = 0
- endif
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa)
-
-! plant canopy sfc wtr in m
- VarName='cnwat'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cmc)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001
- if (sm(i,j) /= 0.0) cmc(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa)
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- grnflx(i,j) = spval ! GFS does not have inst ground heat flux
- enddo
- enddo
-
-! frozen precip fraction using nemsio
- VarName='cpofp'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sr)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if(sr(i,j) /= spval) then
-!set range within (0,1)
- sr(i,j)=min(1.,max(0.,sr(i,j)))
- endif
- enddo
- enddo
-
-! sea ice skin temperature
- VarName='tisfc'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ti)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sice(i,j) == spval .or. sice(i,j) == 0.) ti(i,j)=spval
- enddo
- enddo
-
-! vegetation fraction in fraction. using nemsio
- VarName='veg'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,vegfrc)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (vegfrc(i,j) /= spval) then
- vegfrc(i,j) = vegfrc(i,j) * 0.01
- else
- vegfrc(i,j) = 0.0
- endif
- enddo
- enddo
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) vegfrc(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa)
-
-! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam
-
- SLDPTH(1) = 0.10
- SLDPTH(2) = 0.3
- SLDPTH(3) = 0.6
- SLDPTH(4) = 1.0
-
-! liquid volumetric soil mpisture in fraction using nemsio
- VarName='soill1'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,1))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) sh2o(i,j,1) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1)
-
- VarName='soill2'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,2))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) sh2o(i,j,2) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2)
-
- VarName='soill3'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,3))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) sh2o(i,j,3) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3)
-
- VarName='soill4'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,4))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) sh2o(i,j,4) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4)
-
-! volumetric soil moisture using nemsio
- VarName='soilw1'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,1))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) smc(i,j,1) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1)
-
- VarName='soilw2'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,2))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) smc(i,j,2) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2)
-
- VarName='soilw3'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,3))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) smc(i,j,3) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3)
-
- VarName='soilw4'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,4))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) smc(i,j,4) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4)
-
-! soil temperature using nemsio
- VarName='soilt1'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,1))
-! mask open water areas, combine with sea ice tmp
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,1) = spval
- !if (sm(i,j) /= 0.0) stc(i,j,1) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1)
-
- VarName='soilt2'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,2))
-! mask open water areas, combine with sea ice tmp
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,2) = spval
- !if (sm(i,j) /= 0.0) stc(i,j,2) = spval
- enddo
- enddo
- if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2)
-
- VarName='soilt3'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,3))
-! mask open water areas, combine with sea ice tmp
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,3) = spval
- !if (sm(i,j) /= 0.0) stc(i,j,3) = spval
- enddo
- enddo
- if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3)
-
- VarName='soilt4'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,4))
-! mask open water areas, combine with sea ice tmp
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,4) = spval
- !if (sm(i,j) /= 0.0) stc(i,j,4) = spval
- enddo
- enddo
- if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4)
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1
- ncfrcv(i,j) = 1.0
- acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1
- ncfrst(i,j) = 1.0
- bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF
- rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave
- enddo
- enddo
-! trdlw(i,j) = 6.0
- ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1
-
-! time averaged incoming sfc longwave
- VarName='dlwrf_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwin)
-
-! inst incoming sfc longwave
- VarName='dlwrf'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rlwin)
-
-! time averaged outgoing sfc longwave
- VarName='ulwrf_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwout)
-! inst outgoing sfc longwave
- VarName='ulwrf'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,radot)
-
-! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa)
-
-! time averaged outgoing model top longwave using gfsio
- VarName='ulwrf_avetoa'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwtoa)
-! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa)
-
-! GFS incoming sfc longwave has been averaged, set ARDLW to 1
- ardsw=1.0
-! trdsw=6.0
-
-! time averaged incoming sfc shortwave
- VarName='dswrf_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswin)
-! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa)
-
-! inst incoming sfc shortwave
- VarName='dswrf'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswin)
-
-! inst incoming clear sky sfc shortwave
- VarName='csdlf'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswinc)
-
-! time averaged incoming sfc uv-b using getgb
- VarName='duvb_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,auvbin)
-! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa)
-
-! time averaged incoming sfc clear sky uv-b using getgb
- VarName='cduvb_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,auvbinc)
-! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa)
-
-! time averaged outgoing sfc shortwave using gfsio
- VarName='uswrf_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswout)
-! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa)
-
-! inst outgoing sfc shortwave using gfsio
- VarName='uswrf'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswout)
-
-! time averaged model top incoming shortwave
- VarName='dswrf_avetoa'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswintoa)
-! if(debugprint)print*,'sample l',VarName,' = ',1,aswintoa(isa,jsa)
-
-! time averaged model top outgoing shortwave
- VarName='uswrf_avetoa'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswtoa)
-! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa)
-
-! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux
-! has reversed sign convention using gfsio
- VarName='shtfl_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcshx)
-! where (sfcshx /= spval)sfcshx=-sfcshx
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa)
-
-! inst surface sensible heat flux
- VarName='shtfl'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,twbs)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (twbs(i,j) /= spval) twbs(i,j) = -twbs(i,j)
- enddo
- enddo
-
-! GFS surface flux has been averaged, set ASRFC to 1
- asrfc=1.0
-! tsrfc=6.0
-
-! time averaged surface latent heat flux, multiplied by -1 because wrf model flux
-! has reversed sign vonvention using gfsio
- VarName='lhtfl_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfclhx)
-! where (sfclhx /= spval)sfclhx=-sfclhx
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa)
-
-! inst surface latent heat flux
- VarName='lhtfl'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,qwbs)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (qwbs(i,j) /= spval) qwbs(i,j) = -qwbs(i,j)
- enddo
- enddo
-
- if(me==0)print*,'rdaod= ',rdaod
-! inst aod550 optical depth
- if(rdaod) then
- VarName='aod550'
- call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,aod550)
-
- VarName='du_aod550'
- call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,du_aod550)
-
- VarName='ss_aod550'
- call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,ss_aod550)
-
- VarName='su_aod550'
- call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,su_aod550)
-
- VarName='oc_aod550'
- call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,oc_aod550)
-
- VarName='bc_aod550'
- call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,bc_aod550)
- end if
-
-! time averaged ground heat flux using nemsio
- VarName='gflux_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,subshx)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa)
-
-! inst ground heat flux using nemsio
- VarName='gflux'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,grnflx)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval
- enddo
- enddo
-
-! time averaged zonal momentum flux using gfsio
- VarName='uflx_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcux)
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa)
-
-! time averaged meridional momentum flux using nemsio
- VarName='vflx_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcvx)
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa)
-
-! dong read in inst surface flux
-! inst zonal momentum flux using gfsio
-! VarName='uflx'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcuxi)
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfcuxi(isa,jsa)
-
-! inst meridional momentum flux using nemsio
-! VarName='vflx'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcvxi)
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvxi(isa,jsa)
-
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- sfcuvx(i,j) = spval ! GFS does not use total momentum flux
- enddo
- enddo
-
-! time averaged zonal gravity wave stress using nemsio
- VarName='u-gwd_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,gtaux)
-! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa)
-
-! time averaged meridional gravity wave stress using getgb
- VarName='v-gwd_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,gtauy)
-! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa)
-
-! time averaged accumulated potential evaporation
- VarName='pevpr_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgpotevp)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa)
-
-! inst potential evaporation
- VarName='pevpr'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,potevp)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval
- enddo
- enddo
-
- do l=1,lm
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
-! GFS does not have temperature tendency due to long wave radiation
- rlwtt(i,j,l) = spval
-! GFS does not have temperature tendency due to short wave radiation
- rswtt(i,j,l) = spval
-! GFS does not have temperature tendency due to latent heating from convection
- tcucn(i,j,l) = spval
- tcucns(i,j,l) = spval
-! GFS does not have temperature tendency due to latent heating from grid scale
- train(i,j,l) = spval
- enddo
- enddo
- enddo
-
-! set avrain to 1
- avrain=1.0
- avcnvc=1.0
- theat=6.0 ! just in case GFS decides to output T tendency
-
-! 10 m u using nemsio
- VarName='ugrd10m'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,u10)
-
- do j=jsta,jend
- do i=1,im
- u10h(i,j)=u10(i,j)
- end do
- end do
-! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa)
-
-! 10 m v using gfsio
- VarName='vgrd10m'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,v10)
-
- do j=jsta,jend
- do i=1,im
- v10h(i,j)=v10(i,j)
- end do
- end do
-! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa)
-
-! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon
- VarName='vtype'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf)
-! where (buf /= spval)
-! ivgtyp=nint(buf)
-! elsewhere
-! ivgtyp=0 !need to feed reasonable value to crtm
-! end where
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- if (buf(i,j) < spval) then
- ivgtyp(i,j) = nint(buf(i,j))
- else
- ivgtyp(i,j) = 0
- endif
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa)
-
-! soil type, it's in GFS surface file, hopefully will merge into gfsio soon
- VarName='sotyp'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf)
- VcoordName='sfc'
- l=1
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- if (buf(i,j) < spval) then
- isltyp(i,j) = nint(buf(i,j))
- else
- isltyp(i,j) = 0 !need to feed reasonable value to crtm
- endif
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa)
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- smstav(i,j) = spval ! GFS does not have soil moisture availability
-! smstot(i,j) = spval ! GFS does not have total soil moisture
- sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation
- acsnow(i,j) = spval ! GFS does not have averaged accumulated snow
- acsnom(i,j) = spval ! GFS does not have snow melt
-! sst(i,j) = spval ! GFS does not have sst????
- thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute
- qz0(i,j) = spval ! GFS does not output humidity at roughness length
- uz0(i,j) = spval ! GFS does not output u at roughness length
- vz0(i,j) = spval ! GFS does not output humidity at roughness length
- enddo
- enddo
- do l=1,lm
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- EL_PBL(i,j,l) = spval ! GFS does not have mixing length
- exch_h(i,j,l) = spval ! GFS does not output exchange coefficient
- enddo
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa)
-
-! retrieve inst convective cloud top, GFS has cloud top pressure instead of index,
-! will need to modify CLDRAD.f to use pressure directly instead of index
-! VarName='pres'
-! VcoordName='convect-cld top'
-! l=1
-! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa)
- VarName='prescnvclt'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptop)
-
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- htop(i,j) = spval
- if(ptop(i,j) <= 0.0) ptop(i,j) = spval
- enddo
- enddo
- do j=jsta,jend
- do i=1,im
- if(ptop(i,j) < spval)then
- do l=1,lm
- if(ptop(i,j) <= pmid(i,j,l))then
- htop(i,j) = l
-! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', &
-! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j)
- exit
- end if
- end do
- end if
- end do
- end do
-
-! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index,
-! will need to modify CLDRAD.f to use pressure directly instead of index
- VarName='prescnvclb'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbot)
-! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- hbot(i,j) = spval
- if(pbot(i,j) <= 0.0) pbot(i,j) = spval
- enddo
- enddo
- do j=jsta,jend
- do i=1,im
-! if(.not.lb(i,j))print*,'false bitmask for pbot at '
-! + ,i,j,pbot(i,j)
- if(pbot(i,j) < spval)then
- do l=lm,1,-1
- if(pbot(i,j) >= pmid(i,j,l)) then
- hbot(i,j) = l
-! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', &
-! pbot(i,j),pmid(i,j,l),hbot(i,j)
- exit
- end if
- end do
- end if
- end do
- end do
- if(debugprint)print*,'sample hbot = ',hbot(isa,jsa)
-! retrieve time averaged low cloud top pressure using nemsio
- VarName='pres_avelct'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptopl)
-! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa)
-
-! retrieve time averaged low cloud bottom pressure using nemsio
- VarName='pres_avelcb'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbotl)
-! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa)
-
-! retrieve time averaged low cloud top temperature using nemsio
- VarName='tmp_avelct'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttopl)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa)
-
-! retrieve time averaged middle cloud top pressure using nemsio
- VarName='pres_avemct'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptopm)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa)
-
-! retrieve time averaged middle cloud bottom pressure using nemsio
- VarName='pres_avemcb'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbotm)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa)
-
-! retrieve time averaged middle cloud top temperature using nemsio
- VarName='tmp_avemct'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttopm)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa)
-
-! retrieve time averaged high cloud top pressure using nemsio *********
- VarName='pres_avehct'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptoph)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa)
-
-! retrieve time averaged high cloud bottom pressure using nemsio
- VarName='pres_avehcb'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pboth)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa)
-
-! retrieve time averaged high cloud top temperature using nemsio
- VarName='tmp_avehct'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttoph)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa)
-
-! retrieve boundary layer cloud cover using nemsio
- VarName='tcdc_avebndcl'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pblcfr)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa)
-! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01
- enddo
- enddo
-
-! retrieve cloud work function
- VarName='cwork_aveclm'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cldwork)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa)
-
-! accumulated total (base+surface) runoff
- VarName='watr_acc'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,runoff)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) runoff(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa)
-
-! retrieve shelter max temperature using nemsio
- VarName='tmax_max2m'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxtshltr)
-
-! retrieve shelter min temperature using nemsio
- VarName='tmin_min2m'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,mintshltr)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', &
-! 1,mintshltr(im/2,(jsta+jend)/2)
-
-! retrieve shelter max RH
-! VarName='rh02max'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxrhshltr)
-
-! retrieve shelter min temperature using nemsio
-! VarName='rh02min'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,minrhshltr)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', &
-! 1,mintshltr(im/2,(jsta+jend)/2)
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- MAXRHSHLTR(i,j) = SPVAL
- MINRHSHLTR(i,j) = SPVAL
- enddo
- enddo
-
-! retrieve ice thickness using nemsio
- VarName='icetk'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,dzice)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa)
-
-! retrieve wilting point using nemsio
- VarName='wilt'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smcwlt)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) smcwlt(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa)
-
-! retrieve sunshine duration using nemsio
- VarName='sunsd_acc'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,suntime)
-
-! retrieve field capacity using nemsio
- VarName='fldcp'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,fieldcapa)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) fieldcapa(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa)
-
-! retrieve time averaged surface visible beam downward solar flux
- VarName='vbdsf_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avisbeamswin)
- VcoordName='sfc'
- l=1
-
-! retrieve time averaged surface visible diffuse downward solar flux
- VarName='vddsf_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avisdiffswin)
-
-! retrieve time averaged surface near IR beam downward solar flux
- VarName='nbdsf_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,airbeamswin)
-
-! retrieve time averaged surface near IR diffuse downward solar flux
- VarName='nddsf_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,airdiffswin)
-
-! retrieve time averaged surface clear sky outgoing LW
- VarName='csulf'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwoutc)
-
-! retrieve time averaged TOA clear sky outgoing LW
- VarName='csulftoa'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwtoac)
-
-! retrieve time averaged surface clear sky outgoing SW
- VarName='csusf'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswoutc)
-
-! retrieve time averaged TOA clear sky outgoing LW
- VarName='csusftoa'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswtoac)
-
-! retrieve time averaged surface clear sky incoming LW
- VarName='csdlf'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwinc)
-
-! retrieve time averaged surface clear sky incoming SW
- VarName='csdsf'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswinc)
-
-! retrieve shelter max specific humidity using nemsio
- VarName='spfhmax_max2m'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxqshltr)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',
-! 1,maxqshltr(isa,jsa)
-
-! retrieve shelter min temperature using nemsio
- VarName='spfhmin_min2m'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,minqshltr)
-
-! retrieve storm runoff using nemsio
- VarName='ssrun_acc'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,SSROFF)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) ssroff(i,j) = spval
- enddo
- enddo
-
-! retrieve direct soil evaporation
- VarName='evbs_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgedir)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) avgedir(i,j) = spval
- enddo
- enddo
-
-! retrieve CANOPY WATER EVAP
- VarName='evcw_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgecan)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) avgecan(i,j) = spval
- enddo
- enddo
-
-! retrieve PLANT TRANSPIRATION
- VarName='trans_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgetrans)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) avgetrans(i,j) = spval
- enddo
- enddo
-
-! retrieve snow sublimation
- VarName='sbsno_ave'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgesnow)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval
- enddo
- enddo
-
-! retrive total soil moisture
- VarName='soilm'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smstot)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) smstot(i,j) = spval
- enddo
- enddo
-
-! retrieve snow phase change heat flux
- VarName='snohf'
- call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
- ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,snopcx)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) snopcx(i,j) = spval
- enddo
- enddo
-
-! GFS does not have deep convective cloud top and bottom fields
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- HTOPD(i,j) = SPVAL
- HBOTD(i,j) = SPVAL
- HTOPS(i,j) = SPVAL
- HBOTS(i,j) = SPVAL
- CUPPT(i,j) = SPVAL
- enddo
- enddo
-
-! done with flux file, close it for now
- Status=nf90_close(ncid2d)
-! deallocate(tmp,recname,reclevtyp,reclev)
-
-! pos east
-! call collect_loc(gdlat,dummy)
-! if(me == 0)then
-! latstart = nint(dummy(1,1)*gdsdegr)
-! latlast = nint(dummy(im,jm)*gdsdegr)
-! print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,&
-! 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1)
-! end if
-! call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn)
-! call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn)
-! write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me
-! call collect_loc(gdlon,dummy)
-! if(me == 0)then
-! lonstart = nint(dummy(1,1)*gdsdegr)
-! lonlast = nint(dummy(im,jm)*gdsdegr)
-! end if
-! call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn)
-! call mpi_bcast(lonlast, 1,MPI_INTEGER,0,mpi_comm_comp,irtn)
-
-! write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast
-!
-
-! generate look up table for lifted parcel calculations
-
- THL = 210.
- PLQ = 70000.
- pt_TBL = 10000. ! this is for 100 hPa added by Moorthi
-
- CALL TABLE(PTBL,TTBL,PT_TBL, &
- RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0)
-
- CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q)
-
-!
-!
- IF(ME == 0)THEN
- WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: '
- WRITE(6,51) (SPL(L),L=1,LSM)
- 50 FORMAT(14(F4.1,1X))
- 51 FORMAT(8(F8.1,1X))
- ENDIF
-!
-!$omp parallel do private(l)
- DO L = 1,LSM
- ALSL(L) = LOG(SPL(L))
- END DO
-!
-!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN
- if(me == 0)then
- print*,'writing out igds'
- igdout = 110
-! open(igdout,file='griddef.out',form='unformatted'
-! + ,status='unknown')
- if(maptype == 1)THEN ! Lambert conformal
- WRITE(igdout)3
- WRITE(6,*)'igd(1)=',3
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)8
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)0
- WRITE(igdout)64
- WRITE(igdout)TRUELAT2
- WRITE(igdout)TRUELAT1
- WRITE(igdout)255
- ELSE IF(MAPTYPE == 2)THEN !Polar stereographic
- WRITE(igdout)5
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)8
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)0
- WRITE(igdout)64
- WRITE(igdout)TRUELAT2 !Assume projection at +-90
- WRITE(igdout)TRUELAT1
- WRITE(igdout)255
- ! Note: The calculation of the map scale factor at the standard
- ! lat/lon and the PSMAPF
- ! Get map factor at 60 degrees (N or S) for PS projection, which will
- ! be needed to correctly define the DX and DY values in the GRIB GDS
- if (TRUELAT1 < 0.) THEN
- LAT = -60.
- else
- LAT = 60.
- end if
-
- CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF)
-
- ELSE IF(MAPTYPE == 3) THEN !Mercator
- WRITE(igdout)1
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)8
- WRITE(igdout)latlast
- WRITE(igdout)lonlast
- WRITE(igdout)TRUELAT1
- WRITE(igdout)0
- WRITE(igdout)64
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)255
- ELSE IF(MAPTYPE == 0 .OR. MAPTYPE == 203)THEN !A STAGGERED E-GRID
- WRITE(igdout)203
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)136
- WRITE(igdout)CENLAT
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)64
- WRITE(igdout)0
- WRITE(igdout)0
- WRITE(igdout)0
- END IF
- end if
-!
-!
-
- RETURN
- END
-
diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f
deleted file mode 100644
index 624807426..000000000
--- a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f
+++ /dev/null
@@ -1,2648 +0,0 @@
-!> @file
-! . . .
-!> SUBPROGRAM: INITPOST_GFS_NETCDF_PARA INITIALIZE POST FOR RUN
-!! PRGRMMR: Wen Meng DATE: 2020-02-04
-!!
-!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND
-!! VARIABLES AT THE START OF GFS MODEL OR POST
-!! PROCESSOR RUN.
-!!
-!! REVISION HISTORY
-!! 2020-02-04 W Meng start from INITPOST_GFS_NETCDF.f
-!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend)
-!!
-!! USAGE: CALL INITPOST_GFS_NETCDF_PARA
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! NONE
-!! LIBRARY:
-!! COMMON - CTLBLK
-!! LOOKUP
-!! SOILDEPTH
-!!
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
- SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d)
-
-
- use netcdf
- use vrbls4d, only: dust, SALT, SUSO, SOOT, WASO, PP25, PP10
- use vrbls3d, only: t, q, uh, vh, pmid, pint, alpint, dpres, zint, zmid, o3, &
- qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, &
- tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, &
- o3vdiff, o3prod, o3tndy, mwpv, unknown, vdiffzacce, zgdrag,cnvctummixing, &
- vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, &
- cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp, &
- wh, qqg, ref_10cm
- use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, &
- cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, &
- tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, landfrac, radot, sigt4, &
- cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, &
- islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, &
- bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, &
- rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, &
- snopcx, sfcux, sfcvx, sfcuxi, sfcvxi, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, &
- smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, &
- uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, &
- ptoph, pboth, pblcfr, ttoph, runoff, tecan, tetran, tedir, twa, maxtshltr, &
- mintshltr, maxrhshltr, fdnsst, &
- minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, &
- cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa,rel_vort_maxhy1, &
- maxqshltr, minqshltr, acond, sr, u10h, v10h,refd_max, w_up_max, w_dn_max, &
- up_heli_max,up_heli_min,up_heli_max03,up_heli_min03,rel_vort_max01,u10max, v10max, &
- avgedir,avgecan,paha,pahi,avgetrans,avgesnow,avgprec_cont,avgcprate_cont,rel_vort_max, &
- avisbeamswin,avisdiffswin,airbeamswin,airdiffswin,refdm10c_max,wspd10max, &
- alwoutc,alwtoac,aswoutc,aswtoac,alwinc,aswinc,avgpotevp,snoavg, &
- ti,aod550,du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550
- use soil, only: sldpth, sh2o, smc, stc
- use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice
- use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, &
- eps => con_eps, epsm1 => con_epsm1
- use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa,pi
- use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, &
- ttblq, rdpq, rdtheq, stheq, the0q, the0
- use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, &
- ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, &
- jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,&
- ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, &
- jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, &
- nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER,rdaod
- use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, &
- dxval, dyval, truelat2, truelat1, psmapf, cenlat,lonstartv, lonlastv, cenlonv, &
- latstartv, latlastv, cenlatv,latstart_r,latlast_r,lonstart_r,lonlast_r
-
- use upp_physics, only: fpvsnew
-!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- implicit none
-!
-! type(nemsio_gfile) :: nfile,ffile,rfile
- integer,parameter :: nvar2d=48
-! character(nemsio_charkind) :: name2d(nvar2d)
- integer :: nvar3d, numDims
-! character(nemsio_charkind), allocatable :: name3din(:), name3dout(:)
-! character(nemsio_charkind) :: varname,levtype
-!
-! INCLUDE/SET PARAMETERS.
-!
- INCLUDE "mpif.h"
-
-! integer,parameter:: MAXPTS=1000000 ! max im*jm points
-!
-! real,parameter:: con_g =9.80665e+0! gravity
-! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O
-! real,parameter:: con_rd =2.8705e+2 ! gas constant air
-! real,parameter:: con_fvirt =con_rv/con_rd-1.
-! real,parameter:: con_eps =con_rd/con_rv
-! real,parameter:: con_epsm1 =con_rd/con_rv-1
-!
-! This version of INITPOST shows how to initialize, open, read from, and
-! close a NetCDF dataset. In order to change it to read an internal (binary)
-! dataset, do a global replacement of _ncd_ with _int_.
-
- real, parameter :: gravi = 1.0/grav
- character(len=20) :: VarName, VcoordName
- integer :: Status, fldsize, fldst, recn, recn_vvel
- character startdate*19,SysDepInfo*80,cgar*1
- character startdate2(19)*4
-!
-! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK
-! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE.
-!
-! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE
-! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE.
- LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL
-! logical, parameter :: debugprint = .true., zerout = .false.
- logical, parameter :: debugprint = .false., zerout = .false.
- logical :: convert_rad_to_deg=.false.
- CHARACTER*32 varcharval
-! CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC
- CHARACTER*4 RESTHR
- CHARACTER FNAME*255,ENVAR*50
- INTEGER IDATE(8),JDATE(8),JPDS(200),JGDS(200),KPDS(200),KGDS(200)
-! LOGICAL*1 LB(IM,JM)
-!
-! INCLUDE COMMON BLOCKS.
-!
-! DECLARE VARIABLES.
-!
-! REAL fhour
- integer nfhour ! forecast hour from nems io file
- integer fhzero !bucket
- real dtp !physics time step
- REAL RINC(5)
-
- REAL DUMMY(IM,JM)
-!jw
- integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, &
- I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, &
- nframed2,iunitd3d,ierr,idum,iret,nrec,idrt
- integer ncid3d,ncid2d,varid,nhcas
- real TSTART,TLMH,TSPH,ES,FACT,soilayert,soilayerb,zhour,dum, &
- tvll,pmll,tv, tx1, tx2
-
- character*20,allocatable :: recname(:)
- integer, allocatable :: reclev(:), kmsk(:,:)
- real, allocatable :: glat1d(:), glon1d(:), qstl(:)
- real, allocatable :: wrk1(:,:), wrk2(:,:)
- real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), &
- qs2d(:,:), cw2d(:,:), cfr2d(:,:)
- real(kind=4),allocatable :: vcoord4(:,:,:)
- real, dimension(lm+1) :: ak5, bk5
- real*8, allocatable :: pm2d(:,:), pi2d(:,:)
- real, allocatable :: tmp(:)
- real :: buf(im,jsta_2l:jend_2u)
- real :: buf3d(im,jsta_2l:jend_2u,lm)
-
-! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) &
-! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u)
-
- real LAT
- integer isa, jsa, latghf, jtem, idvc, idsl, nvcoord, ip1, nn, npass
-
- integer, parameter :: npass2=5, npass3=30
- real, parameter :: third=1.0/3.0
- INTEGER, DIMENSION(2) :: ij4min, ij4max
- REAL :: omgmin, omgmax
- real, allocatable :: d2d(:,:), u2d(:,:), v2d(:,:), omga2d(:,:)
- REAL, ALLOCATABLE :: ps2d(:,:),psx2d(:,:),psy2d(:,:)
- real, allocatable :: div3d(:,:,:)
- real(kind=4),allocatable :: vcrd(:,:)
- real :: dum_const
-
-!***********************************************************************
-! START INIT HERE.
-!
- WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NETCDF_PARA'
- WRITE(6,*)'me=',me, &
- 'jsta_2l=',jsta_2l,'jend_2u=', &
- jend_2u,'im=',im
-!
- isa = im / 2
- jsa = (jsta+jend) / 2
-
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- buf(i,j) = spval
- enddo
- enddo
-
- Status=nf90_get_att(ncid3d,nf90_global,'ak',ak5)
- if(Status/=0)then
- print*,'ak not found; assigning missing value'
- ak5=spval
- else
- if(me==0)print*,'ak5= ',ak5
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'idrt',idrt)
- if(Status/=0)then
- print*,'idrt not in netcdf file,reading grid'
- Status=nf90_get_att(ncid3d,nf90_global,'grid',varcharval)
- if(Status/=0)then
- print*,'idrt and grid not in netcdf file, set default to latlon'
- idrt=0
- MAPTYPE=0
- else
- if(trim(varcharval)=='rotated_latlon')then
- MAPTYPE=207
- idrt=207
- Status=nf90_get_att(ncid3d,nf90_global,'cen_lon',dum_const)
- if(Status/=0)then
- print*,'cen_lon not found; assigning missing value'
- cenlon=spval
- else
- if(dum_const<0.)then
- cenlon=nint((dum_const+360.)*gdsdegr)
- else
- cenlon=dum_const*gdsdegr
- end if
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'cen_lat',dum_const)
- if(Status/=0)then
- print*,'cen_lat not found; assigning missing value'
- cenlat=spval
- else
- cenlat=dum_const*gdsdegr
- end if
-
- Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const)
- if(Status/=0)then
- print*,'lonstart_r not found; assigning missing value'
- lonstart_r=spval
- else
- if(dum_const<0.)then
- lonstart_r=nint((dum_const+360.)*gdsdegr)
- else
- lonstart_r=dum_const*gdsdegr
- end if
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const)
- if(Status/=0)then
- print*,'latstart_r not found; assigning missing value'
- latstart_r=spval
- else
- latstart_r=dum_const*gdsdegr
- end if
-
- Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const)
- if(Status/=0)then
- print*,'lonlast_r not found; assigning missing value'
- lonlast_r=spval
- else
- if(dum_const<0.)then
- lonlast_r=nint((dum_const+360.)*gdsdegr)
- else
- lonlast_r=dum_const*gdsdegr
- end if
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const)
- if(Status/=0)then
- print*,'latlast_r not found; assigning missing value'
- latlast_r=spval
- else
- latlast_r=dum_const*gdsdegr
- end if
-
- Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const)
- if(Status/=0)then
- print*,'dlmd not found; assigning missing value'
- dxval=spval
- else
- dxval=dum_const*gdsdegr
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const)
- if(Status/=0)then
- print*,'dphd not found; assigning missing value'
- dyval=spval
- else
- dyval=dum_const*gdsdegr
- end if
-
- print*,'lonstart,latstart,cenlon,cenlat,dyval,dxval', &
- lonstart,latstart,cenlon,cenlat,dyval,dxval
-
-! Jili Dong add support for regular lat lon (2019/03/22) start
- else if(trim(varcharval)=='latlon')then
- MAPTYPE=0
- idrt=0
-
- Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const)
- if(Status/=0)then
- print*,'lonstart not found; assigning missing value'
- lonstart=spval
- else
- if(dum_const<0.)then
- lonstart=nint((dum_const+360.)*gdsdegr)
- else
- lonstart=dum_const*gdsdegr
- end if
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const)
- if(Status/=0)then
- print*,'latstart not found; assigning missing value'
- latstart=spval
- else
- latstart=dum_const*gdsdegr
- end if
-
- Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const)
- if(Status/=0)then
- print*,'lonlast not found; assigning missing value'
- lonlast=spval
- else
- if(dum_const<0.)then
- lonlast=nint((dum_const+360.)*gdsdegr)
- else
- lonlast=dum_const*gdsdegr
- end if
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const)
- if(Status/=0)then
- print*,'latlast not found; assigning missing value'
- latlast=spval
- else
- latlast=dum_const*gdsdegr
- end if
-
- Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const)
- if(Status/=0)then
- print*,'dlmd not found; assigning missing value'
- dxval=spval
- else
- dxval=dum_const*gdsdegr
- end if
- Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const)
- if(Status/=0)then
- print*,'dphd not found; assigning missing value'
- dyval=spval
- else
- dyval=dum_const*gdsdegr
- end if
-
- print*,'lonstart,latstart,dyval,dxval', &
- lonstart,lonlast,latstart,latlast,dyval,dxval
-
-! Jili Dong add support for regular lat lon (2019/03/22) end
-
- else if(trim(varcharval)=='gaussian')then
- MAPTYPE=4
- idrt=4
- else ! setting default maptype
- MAPTYPE=0
- idrt=0
- end if
- end if !end reading grid
- end if !end reading idrt
- if(me==0)print*,'idrt MAPTYPE= ',idrt,MAPTYPE
-! STEP 1. READ MODEL OUTPUT FILE
-!
-!
-!***
-!
-! LMH and LMV always = LM for sigma-type vert coord
-
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i = 1, im
- LMV(i,j) = lm
- LMH(i,j) = lm
- end do
- end do
-
-! HTM VTM all 1 for sigma-type vert coord
-
-!$omp parallel do private(i,j,l)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- HTM (i,j,l) = 1.0
- VTM (i,j,l) = 1.0
- end do
- end do
- end do
-
- Status=nf90_get_att(ncid3d,nf90_global,'nhcas',nhcas)
- if(Status/=0)then
- print*,'nhcas not in netcdf file, set default to nonhydro'
- nhcas=0
- end if
- if(me==0)print*,'nhcas= ',nhcas
- if (nhcas == 0 ) then !non-hydrostatic case
- nrec=15
- allocate (recname(nrec))
- recname=[character(len=20) :: 'ugrd','vgrd','spfh','tmp','o3mr', &
- 'presnh','dzdt', 'clwmr','dpres', &
- 'delz','icmr','rwmr', &
- 'snmr','grle','cld_amt']
- else
- nrec=8
- allocate (recname(nrec))
- recname=[character(len=20) :: 'ugrd','vgrd','tmp','spfh','o3mr', &
- 'hypres', 'clwmr','dpres']
- endif
-
-! write(0,*)'nrec=',nrec
- !allocate(recname(nrec),reclevtyp(nrec),reclev(nrec))
- allocate(glat1d(jm),glon1d(im))
- allocate(vcoord4(lm+1,3,2))
-
-! hardwire idate for now
-! idate=(/2017,08,07,00,0,0,0,0/)
-! get cycle start time
- Status=nf90_inq_varid(ncid3d,'time',varid)
- if(Status/=0)then
- print*,'time not in netcdf file, stopping'
- STOP 1
- else
- Status=nf90_get_att(ncid3d,varid,'units',varcharval)
- if(Status/=0)then
- print*,'time unit not available'
- else
- print*,'time unit read from netcdf file= ',varcharval
-! assume use hours as unit
-! idate_loc=index(varcharval,'since')+6
- read(varcharval,101)idate(1),idate(2),idate(3),idate(4),idate(5)
- end if
-! Status=nf90_inquire_dimension(ncid3d,varid,len=ntimes)
-! allocate(fhours(ntimes))
-! status = nf90_inq_varid(ncid3d,varid,fhours)
-! Status=nf90_get_var(ncid3d,varid,nfhour,start=(/1/), &
-! count=(/1/))
-! if(Status/=0)then
-! print*,'forecast hour not in netcdf file, stopping'
-! STOP 1
-! end if
- end if
- 101 format(T13,i4,1x,i2,1x,i2,1x,i2,1x,i2)
- print*,'idate= ',idate(1:5)
-! get longitude
- Status=nf90_inq_varid(ncid3d,'grid_xt',varid)
- Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims)
- if(debugprint)print*,'number of dim for gdlon ',numDims
- if(numDims==1)then
- Status=nf90_get_var(ncid3d,varid,glon1d)
- do j=jsta,jend
- do i=1,im
- gdlon(i,j) = real(glon1d(i),kind=4)
- end do
- end do
- lonstart = nint(glon1d(1)*gdsdegr)
- lonlast = nint(glon1d(im)*gdsdegr)
- dxval = nint(abs(glon1d(1)-glon1d(2))*gdsdegr)
- else if(numDims==2)then
- Status=nf90_get_var(ncid3d,varid,dummy)
- if(maxval(abs(dummy))<2.0*pi)convert_rad_to_deg=.true.
- if(convert_rad_to_deg)then
- do j=jsta,jend
- do i=1,im
- gdlon(i,j) = real(dummy(i,j),kind=4)*180./pi
- end do
- end do
- else
- do j=jsta,jend
- do i=1,im
- gdlon(i,j) = real(dummy(i,j),kind=4)
- end do
- end do
- end if
- if(convert_rad_to_deg)then
- lonstart = nint(dummy(1,1)*gdsdegr)*180./pi
- lonlast = nint(dummy(im,jm)*gdsdegr)*180./pi
- dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr)*180./pi
- else
- lonstart = nint(dummy(1,1)*gdsdegr)
- lonlast = nint(dummy(im,jm)*gdsdegr)
- dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr)
- end if
-
-! Jili Dong add support for regular lat lon (2019/03/22) start
- if (MAPTYPE == 0) then
- if(lonstart<0.)then
- lonstart=lonstart+360.*gdsdegr
- end if
- if(lonlast<0.)then
- lonlast=lonlast+360.*gdsdegr
- end if
- end if
-! Jili Dong add support for regular lat lon (2019/03/22) end
-
- end if
- print*,'lonstart,lonlast,dxval ',lonstart,lonlast,dxval
-! get latitude
- Status=nf90_inq_varid(ncid3d,'grid_yt',varid)
- Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims)
- if(debugprint)print*,'number of dim for gdlat ',numDims
- if(numDims==1)then
- Status=nf90_get_var(ncid3d,varid,glat1d)
- do j=jsta,jend
- do i=1,im
- gdlat(i,j) = real(glat1d(j),kind=4)
- end do
- end do
- latstart = nint(glat1d(1)*gdsdegr)
- latlast = nint(glat1d(jm)*gdsdegr)
- dyval = nint(abs(glat1d(1)-glat1d(2))*gdsdegr)
- else if(numDims==2)then
- Status=nf90_get_var(ncid3d,varid,dummy)
- if(maxval(abs(dummy))1000.)print*,'bad T ',t(i,j,l)
- enddo
- enddo
- enddo
- call read_netcdf_3d_para(ncid3d,im,jm,jsta,jsta_2l,jend,jend_2u, &
- spval,recname(11),qqi(1,jsta_2l,1),lm)
- call read_netcdf_3d_para(ncid3d,im,jm,jsta,jsta_2l,jend,jend_2u, &
- spval,recname(12),qqr(1,jsta_2l,1),lm)
- call read_netcdf_3d_para(ncid3d,im,jm,jsta,jsta_2l,jend,jend_2u, &
- spval,recname(13),qqs(1,jsta_2l,1),lm)
- call read_netcdf_3d_para(ncid3d,im,jm,jsta,jsta_2l,jend,jend_2u, &
- spval,recname(14),qqg(1,jsta_2l,1),lm)
- call read_netcdf_3d_para(ncid3d,im,jm,jsta,jsta_2l,jend,jend_2u, &
- spval,recname(15),cfr(1,jsta_2l,1),lm)
-
-! calculate CWM from FV3 output
- do l=1,lm
- do j=jsta,jend
- do i=1,im
- cwm(i,j,l)=qqg(i,j,l)+qqs(i,j,l)+qqr(i,j,l)+qqi(i,j,l)+qqw(i,j,l)
- enddo
- enddo
- if(debugprint)print*,'sample l,t,q,u,v,w,= ',isa,jsa,l &
- ,t(isa,jsa,l),q(isa,jsa,l),uh(isa,jsa,l),vh(isa,jsa,l) &
- ,wh(isa,jsa,l)
- if(debugprint)print*,'sample l cwm for FV3',l, &
- cwm(isa,jsa,l)
- end do
-
-! surface pressure
- VarName='pressfc'
- call read_netcdf_2d_para(ncid3d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,pint(1,jsta_2l,lp1))
- do j=jsta,jend
- do i=1,im
-! if(pint(i,j,lp1)>1.0E6 .or. pint(1,jsta_2l,lp1)<50000.) &
-! print*,'bad psfc ',i,j,pint(i,j,lp1)
- end do
- end do
- if(debugprint)print*,'sample ',VarName,' =',pint(isa,jsa,lp1)
-
- pt = ak5(1)
-
- do j=jsta,jend
- do i=1,im
- pint(i,j,1)= pt
- end do
- end do
-
- do l=2,lp1
- do j=jsta,jend
- do i=1,im
- pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1)
- enddo
- enddo
-! if (me == 0) print*,'sample model pint,pmid' ,ii,jj,l &
-! ,pint(ii,jj,l),pmid(ii,jj,l)
- end do
-
-!compute pmid from averaged two layer pint
- do l=lm,1,-1
- do j=jsta,jend
- do i=1,im
- pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1))
- enddo
- enddo
- enddo
-
-! surface height from FV3
-! dong set missing value for zint
-! zint=spval
- VarName='hgtsfc'
- call read_netcdf_2d_para(ncid3d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,zint(1,jsta_2l,lp1))
- if(debugprint)print*,'sample ',VarName,' =',zint(isa,jsa,lp1)
- do j=jsta,jend
- do i=1,im
- if (zint(i,j,lp1) /= spval) then
- fis(i,j) = zint(i,j,lp1) * grav
- else
- fis(i,j) = spval
- endif
- enddo
- enddo
-
- do l=lm,1,-1
- do j=jsta,jend
- do i=1,im
- if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then
-!make sure delz is positive
- zint(i,j,l)=zint(i,j,l+1)+abs(buf3d(i,j,l))
-! if(zint(i,j,l)>1.0E6)print*,'bad H ',i,j,l,zint(i,j,l)
- else
- zint(i,j,l)=spval
- end if
- end do
- end do
- print*,'sample zint= ',isa,jsa,l,zint(isa,jsa,l)
- end do
-
- do l=lp1,1,-1
- do j=jsta,jend
- do i=1,im
- alpint(i,j,l)=log(pint(i,j,l))
- end do
- end do
- end do
-
- do l=lm,1,-1
- do j=jsta,jend
- do i=1,im
- if(zint(i,j,l+1)/=spval .and. zint(i,j,l)/=spval &
- .and. pmid(i,j,l)/=spval)then
- zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* &
- (log(pmid(i,j,l))-alpint(i,j,l+1))/ &
- (alpint(i,j,l)-alpint(i,j,l+1))
- if(zmid(i,j,l)>1.0E6)print*,'bad Hmid ',i,j,l,zmid(i,j,l)
- else
- zmid(i,j,l)=spval
- endif
- end do
- end do
- end do
-
-
- pt = ak5(1)
-
-!
-
- deallocate (vcoord4)
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-!
-
-! done with 3d file, close it for now
- Status=nf90_close(ncid3d)
- deallocate(recname)
-
-! open flux file
- Status = nf90_open(trim(fileNameFlux),ior(nf90_nowrite, nf90_mpiio), &
- ncid2d,comm=mpi_comm_world,info=mpi_info_null)
- if ( Status /= 0 ) then
- print*,'error opening ',fileNameFlux, ' Status = ', Status
- print*,'skip reading of flux file'
- endif
-
-! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD
- VarName='IVEGSRC'
- Status=nf90_get_att(ncid2d,nf90_global,'IVEGSRC',IVEGSRC)
- if (Status /= 0) then
- print*,VarName,' not found-Assigned 1 for IGBP as default'
- IVEGSRC=1
- end if
- if (me == 0) print*,'IVEGSRC= ',IVEGSRC
-
-! set novegtype based on vegetation classification
- if(ivegsrc==2)then
- novegtype=13
- else if(ivegsrc==1)then
- novegtype=20
- else if(ivegsrc==0)then
- novegtype=24
- end if
- if (me == 0) print*,'novegtype= ',novegtype
-
- Status=nf90_get_att(ncid2d,nf90_global,'imp_physics',imp_physics)
- if (Status /= 0) then
- print*,VarName,' not found-Assigned 11 GFDL as default'
- imp_physics=11
- end if
- if (me == 0) print*,'MP_PHYSICS= ',imp_physics
-!
- Status=nf90_get_att(ncid2d,nf90_global,'fhzero',fhzero)
- if (Status /= 0) then
- print*,VarName,' not found-Assigned 3 hours as default'
- fhzero=3
- end if
- if (me == 0) print*,'fhzero= ',fhzero
-!
- Status=nf90_get_att(ncid2d,nf90_global,'dtp',dtp)
- if (Status /= 0) then
- print*,VarName,' not found-Assigned 90s as default'
- dtp=90
- end if
- if (me == 0) print*,'dtp= ',dtp
-! Initializes constants for Ferrier microphysics
- if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95) then
- CALL MICROINIT(imp_physics)
- end if
-
- tprec = float(fhzero)
- if(ifhr>240)tprec=12.
- tclod = tprec
- trdlw = tprec
- trdsw = tprec
- tsrfc = tprec
- tmaxmin = tprec
- td3d = tprec
- print*,'tprec = ',tprec
-
-
-!Set REF_10CM as missning since gfs doesn't ouput it
- do l=1,lm
- do j=jsta,jend
- do i=1,im
- REF_10CM(i,j,l)=spval
- enddo
- enddo
- enddo
-
- VarName='land'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,sm)
- if(debugprint)print*,'sample ',VarName,' =',sm(im/2,(jsta+jend)/2)
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j)
- enddo
- enddo
-
-! sea ice mask
-
- VarName = 'icec'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,sice)
- if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa)
-
-! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea
-! mask=0
-! GFS flux files have land points with non-zero sea ice, per Iredell,
-! these
-! points have sea ice changed to zero, i.e., trust land mask more than
-! sea ice
-! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0
- enddo
- enddo
-
-
-! PBL height using nemsio
- VarName = 'hpbl'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,pblh)
- if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa)
-
-! frictional velocity using nemsio
- VarName='fricv'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,ustar)
-! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa)
-
-! roughness length using getgb
- VarName='sfcr'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,z0)
-! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa)
-
-! sfc exchange coeff
- VarName='sfexc'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,SFCEXC)
-
-! aerodynamic conductance
- VarName='acond'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,acond)
- if(debugprint)print*,'sample ',VarName,' = ',acond(isa,jsa)
-
-! mid day avg albedo
- VarName='albdo_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgalbedo)
- if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa)
- do j=jsta,jend
- do i=1,im
- if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01
- enddo
- enddo
-
-! surface potential T using getgb
- VarName='tmpsfc'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,ths)
-
-! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (ths(i,j) /= spval) then
-! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1)
- ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa
- endif
- QS(i,j) = SPVAL ! GFS does not have surface specific humidity
- twbs(i,j) = SPVAL ! GFS does not have inst sensible heat flux
- qwbs(i,j) = SPVAL ! GFS does not have inst latent heat flux
-!assign sst
- if (sm(i,j) /= 0.0) then
- sst(i,j) = ths(i,j) * (pint(i,j,lp1)/p1000)**capa
- else
- sst(i,j) = spval
- endif
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa)
-
-! foundation temperature
- VarName='tref'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,fdnsst)
- if(debugprint)print*,'sample ',VarName,' = ',fdnsst(isa,jsa)
-
-! GFS does not have time step and physics time step, make up ones since they
-! are not really used anyway
-! NPHS=1.
-! DT=90.
-! DTQ2 = DT * NPHS !MEB need to get physics DT
- DTQ2 = DTP !MEB need to get physics DT
- NPHS=1
- DT = DTQ2/NPHS !MEB need to get DT
- TSPH = 3600./DT
-
-! convective precip in m per physics time step using getgb
-! read 3 hour bucket
- VarName='cpratb_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgcprate)
-! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001)
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa)
-
-! print*,'maxval CPRATE: ', maxval(CPRATE)
-
-! read continuous bucket
- VarName='cprat_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgcprate_cont)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcprate_cont(i,j) /= spval) avgcprate_cont(i,j) = &
- avgcprate_cont(i,j) * (dtq2*0.001)
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',avgcprate_cont(isa,jsa)
-
-! print*,'maxval CPRATE: ', maxval(CPRATE)
-
-! precip rate in m per physics time step using getgb
- VarName='prateb_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgprec)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if(avgprec(i,j) /= spval)avgprec(i,j)=avgprec(i,j)*(dtq2*0.001)
- enddo
- enddo
-
- if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa)
-
-! prec = avgprec !set avg cprate to inst one to derive other fields
-
- VarName='prate_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgprec_cont)
-! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgprec_cont(i,j) /=spval)avgprec_cont(i,j)=avgprec_cont(i,j) &
- * (dtq2*0.001)
- enddo
- enddo
-
- if(debugprint)print*,'sample ',VarName,' = ',avgprec_cont(isa,jsa)
-! precip rate in m per physics time step
- VarName='tprcp'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,prec)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (prec(i,j) /= spval) prec(i,j)=prec(i,j)* (dtq2*0.001) &
- * 1000. / dtp
- enddo
- enddo
-
-! convective precip rate in m per physics time step
- VarName='cnvprcp'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,cprate)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (cprate(i,j) /= spval) then
- cprate(i,j) = max(0.,cprate(i,j)) * (dtq2*0.001) &
- * 1000. / dtp
- else
- cprate(i,j) = 0.
- endif
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',cprate(isa,jsa)
-
-! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f
-
-! max hourly 1-km agl reflectivity
-! VarName='refdmax'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refd_max)
-! if(debugprint)print*,'sample ',VarName,' = ',refd_max(isa,jsa)
-! max hourly -10C reflectivity
-! VarName='refdmax263k'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refdm10c_max)
-! if(debugprint)print*,'sample ',VarName,' = ',refdm10c_max(isa,jsa)
-
-! max hourly u comp of 10m agl wind
-! VarName='u10max'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,u10max)
-! if(debugprint)print*,'sample ',VarName,' = ',u10max(isa,jsa)
-! max hourly v comp of 10m agl wind
-! VarName='v10max'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,v10max)
-! if(debugprint)print*,'sample ',VarName,' = ',v10max(isa,jsa)
-! max hourly 10m agl wind speed
-! VarName='spd10max'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,wspd10max)
-! if(debugprint)print*,'sample ',VarName,' = ',wspd10max(isa,jsa)
-
-
-! 2m T using nemsio
- VarName='tmp2m'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,tshltr)
- if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa)
-
-! inst snow water eqivalent using nemsio
- VarName='weasd'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,sno)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j)==0.) sno(i,j) = spval
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa)
-
-! ave snow cover
- VarName='snowc_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,snoavg)
-! snow cover is multipled by 100 in SURFCE before writing it out
- do j=jsta,jend
- do i=1,im
- if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j)=spval
- if(snoavg(i,j)/=spval)snoavg(i,j)=snoavg(i,j)/100.
- end do
- end do
-
-! snow depth in mm using nemsio
- VarName='snod'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,si)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval
- if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0
- CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency
- lspa(i,j) = spval ! GFS does not have similated precip
- TH10(i,j) = SPVAL ! GFS does not have 10 m theta
- TH10(i,j) = SPVAL ! GFS does not have 10 m theta
- Q10(i,j) = SPVAL ! GFS does not have 10 m humidity
- ALBASE(i,j) = SPVAL ! GFS does not have snow free albedo
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa)
-
-! 2m T using nemsio
- VarName='tmp2m'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,tshltr)
- if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa)
-
-! GFS does not have 2m pres, estimate it, also convert t to theta
- Do j=jsta,jend
- Do i=1,im
- PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j))
- tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta
-! if (j == jm/2 .and. mod(i,50) == 0)
-! + print*,'sample 2m T and P after scatter= '
-! + ,i,j,tshltr(i,j),pshltr(i,j)
- end do
- end do
-
-! 2m specific humidity using nemsio
- VarName='spfh2m'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,qshltr)
- if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa)
-
-! mid day avg albedo in fraction using nemsio
-! VarName='albdosfc'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgalbedo)
-!! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction
-!!$omp parallel do private(i,j)
-! do j=jsta,jend
-! do i=1,im
-! if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01
-! enddo
-! enddo
-! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa)
-
-! time averaged column cloud fractionusing nemsio
- VarName='tcdc_aveclm'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgtcdc)
-! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa)
-
-! GFS probably does not use zenith angle
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- Czen(i,j) = spval
- CZMEAN(i,j) = SPVAL
- enddo
- enddo
-
-! maximum snow albedo in fraction using nemsio
- VarName='snoalb'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,mxsnal)
-! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa)
-
-! land fraction
- VarName='lfrac'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,landfrac)
-
-! GFS probably does not use sigt4, set it to sig*t^4
-!$omp parallel do private(i,j,tlmh)
- Do j=jsta,jend
- Do i=1,im
- TLMH = T(I,J,LM) * T(I,J,LM)
- Sigt4(i,j) = 5.67E-8 * TLMH * TLMH
- End do
- End do
-
-! TG is not used, skip it for now
-
-! GFS does not have inst cloud fraction for high, middle, and low cloud
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- cfrach(i,j) = spval
- cfracl(i,j) = spval
- cfracm(i,j) = spval
- enddo
- enddo
-
-! ave high cloud fraction using nemsio
- VarName='tcdc_avehcl'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgcfrach)
-! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa)
-
-! ave low cloud fraction using nemsio
- VarName='tcdc_avelcl'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgcfracl)
-! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa)
-
-! ave middle cloud fraction using nemsio
- VarName='tcdc_avemcl'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgcfracm)
-! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01
- enddo
- enddo
- if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa)
-
-! inst convective cloud fraction using nemsio
- VarName='tcdccnvcl'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,cnvcfr)
-! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa)
-
-! slope type using nemsio
- VarName='sltyp'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,buf)
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- if (buf(i,j) < spval) then
- islope(i,j) = nint(buf(i,j))
- else
- islope(i,j) = 0
- endif
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa)
-
-! plant canopy sfc wtr in m
- VarName='cnwat'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,cmc)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001
- if (sm(i,j) /= 0.0) cmc(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa)
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- grnflx(i,j) = spval ! GFS does not have inst ground heat flux
- enddo
- enddo
-
-! frozen precip fraction using nemsio
- VarName='cpofp'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,sr)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if(sr(i,j) /= spval) then
-!set range within (0,1)
- sr(i,j)=min(1.,max(0.,sr(i,j)))
- endif
- enddo
- enddo
-
-! sea ice skin temperature
- VarName='tisfc'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,ti)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sice(i,j) == spval .or. sice(i,j) == 0.) ti(i,j)=spval
- enddo
- enddo
-
-! vegetation fraction in fraction. using nemsio
- VarName='veg'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,vegfrc)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (vegfrc(i,j) /= spval) then
- vegfrc(i,j) = vegfrc(i,j) * 0.01
- else
- vegfrc(i,j) = 0.0
- endif
- enddo
- enddo
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) vegfrc(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa)
-
-! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam
-
- SLDPTH(1) = 0.10
- SLDPTH(2) = 0.3
- SLDPTH(3) = 0.6
- SLDPTH(4) = 1.0
-
-! liquid volumetric soil mpisture in fraction using nemsio
- VarName='soill1'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,sh2o(1,jsta_2l,1))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) sh2o(i,j,1) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1)
-
- VarName='soill2'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,sh2o(1,jsta_2l,2))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) sh2o(i,j,2) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2)
-
- VarName='soill3'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,sh2o(1,jsta_2l,3))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) sh2o(i,j,3) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3)
-
- VarName='soill4'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,sh2o(1,jsta_2l,4))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) sh2o(i,j,4) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4)
-
-! volumetric soil moisture using nemsio
- VarName='soilw1'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,smc(1,jsta_2l,1))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) smc(i,j,1) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1)
-
- VarName='soilw2'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,smc(1,jsta_2l,2))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) smc(i,j,2) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2)
-
- VarName='soilw3'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,smc(1,jsta_2l,3))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) smc(i,j,3) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3)
-
- VarName='soilw4'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,smc(1,jsta_2l,4))
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) smc(i,j,4) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4)
-
-! soil temperature using nemsio
- VarName='soilt1'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,stc(1,jsta_2l,1))
-! mask open water areas, combine with sea ice tmp
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,1) = spval
- !if (sm(i,j) /= 0.0) stc(i,j,1) = spval
- enddo
- enddo
- if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1)
-
- VarName='soilt2'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,stc(1,jsta_2l,2))
-! mask open water areas, combine with sea ice tmp
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,2) = spval
- !if (sm(i,j) /= 0.0) stc(i,j,2) = spval
- enddo
- enddo
- if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2)
-
- VarName='soilt3'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,stc(1,jsta_2l,3))
-! mask open water areas, combine with sea ice tmp
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,3) = spval
- !if (sm(i,j) /= 0.0) stc(i,j,3) = spval
- enddo
- enddo
- if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3)
-
- VarName='soilt4'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,stc(1,jsta_2l,4))
-! mask open water areas, combine with sea ice tmp
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,4) = spval
- !if (sm(i,j) /= 0.0) stc(i,j,4) = spval
- enddo
- enddo
- if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4)
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1
- ncfrcv(i,j) = 1.0
- acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1
- ncfrst(i,j) = 1.0
- bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF
- rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave
- enddo
- enddo
-! trdlw(i,j) = 6.0
- ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1
-
-! time averaged incoming sfc longwave
- VarName='dlwrf_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,alwin)
-
-! inst incoming sfc longwave
- VarName='dlwrf'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,rlwin)
-
-! time averaged outgoing sfc longwave
- VarName='ulwrf_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,alwout)
-! inst outgoing sfc longwave
- VarName='ulwrf'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,radot)
-
-! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa)
-
-! time averaged outgoing model top longwave using gfsio
- VarName='ulwrf_avetoa'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,alwtoa)
-! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa)
-
-! GFS incoming sfc longwave has been averaged, set ARDLW to 1
- ardsw=1.0
-! trdsw=6.0
-
-! time averaged incoming sfc shortwave
- VarName='dswrf_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,aswin)
-! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa)
-
-! inst incoming sfc shortwave
- VarName='dswrf'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,rswin)
-
-! inst incoming clear sky sfc shortwave
- VarName='csdlf'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,rswinc)
-
-! time averaged incoming sfc uv-b using getgb
- VarName='duvb_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,auvbin)
-! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa)
-
-! time averaged incoming sfc clear sky uv-b using getgb
- VarName='cduvb_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,auvbinc)
-! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa)
-
-! time averaged outgoing sfc shortwave using gfsio
- VarName='uswrf_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,aswout)
-! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa)
-
-! inst outgoing sfc shortwave using gfsio
- VarName='uswrf'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,rswout)
-
-! time averaged model top incoming shortwave
- VarName='dswrf_avetoa'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,aswintoa)
-! if(debugprint)print*,'sample l',VarName,' = ',1,aswintoa(isa,jsa)
-
-! time averaged model top outgoing shortwave
- VarName='uswrf_avetoa'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,aswtoa)
-! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa)
-
-! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux
-! has reversed sign convention using gfsio
- VarName='shtfl_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,sfcshx)
-! where (sfcshx /= spval)sfcshx=-sfcshx
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa)
-
-! inst surface sensible heat flux
- VarName='shtfl'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,twbs)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (twbs(i,j) /= spval) twbs(i,j) = -twbs(i,j)
- enddo
- enddo
-
-! GFS surface flux has been averaged, set ASRFC to 1
- asrfc=1.0
-! tsrfc=6.0
-
-! time averaged surface latent heat flux, multiplied by -1 because wrf model flux
-! has reversed sign vonvention using gfsio
- VarName='lhtfl_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,sfclhx)
-! where (sfclhx /= spval)sfclhx=-sfclhx
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j)
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa)
-
-! inst surface latent heat flux
- VarName='lhtfl'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,qwbs)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (qwbs(i,j) /= spval) qwbs(i,j) = -qwbs(i,j)
- enddo
- enddo
-
- if(me==0)print*,'rdaod= ',rdaod
-! inst aod550 optical depth
- if(rdaod) then
- VarName='aod550'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,aod550)
-
- VarName='du_aod550'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,du_aod550)
-
- VarName='ss_aod550'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,ss_aod550)
-
- VarName='su_aod550'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,su_aod550)
-
- VarName='oc_aod550'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,oc_aod550)
-
- VarName='bc_aod550'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,bc_aod550)
- endif !end if rdaod
-
-
-! time averaged ground heat flux using nemsio
- VarName='gflux_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,subshx)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa)
-
-! inst ground heat flux using nemsio
- VarName='gflux'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,grnflx)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval
- enddo
- enddo
-
-! time averaged zonal momentum flux using gfsio
- VarName='uflx_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,sfcux)
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa)
-
-! time averaged meridional momentum flux using nemsio
- VarName='vflx_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,sfcvx)
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa)
-
-! dong read in inst surface flux
-! inst zonal momentum flux using gfsio
-! VarName='uflx'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcuxi)
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfcuxi(isa,jsa)
-
-! inst meridional momentum flux using nemsio
-! VarName='vflx'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcvxi)
-! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvxi(isa,jsa)
-
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- sfcuvx(i,j) = spval ! GFS does not use total momentum flux
- enddo
- enddo
-
-! time averaged zonal gravity wave stress using nemsio
- VarName='u-gwd_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,gtaux)
-! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa)
-
-! time averaged meridional gravity wave stress using getgb
- VarName='v-gwd_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,gtauy)
-! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa)
-
-! time averaged accumulated potential evaporation
- VarName='pevpr_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgpotevp)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa)
-
-! inst potential evaporation
- VarName='pevpr'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,potevp)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval
- enddo
- enddo
-
- do l=1,lm
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
-! GFS does not have temperature tendency due to long wave radiation
- rlwtt(i,j,l) = spval
-! GFS does not have temperature tendency due to short wave radiation
- rswtt(i,j,l) = spval
-! GFS does not have temperature tendency due to latent heating from convection
- tcucn(i,j,l) = spval
- tcucns(i,j,l) = spval
-! GFS does not have temperature tendency due to latent heating from grid scale
- train(i,j,l) = spval
- enddo
- enddo
- enddo
-
-! set avrain to 1
- avrain=1.0
- avcnvc=1.0
- theat=6.0 ! just in case GFS decides to output T tendency
-
-! 10 m u using nemsio
- VarName='ugrd10m'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,u10)
-
- do j=jsta,jend
- do i=1,im
- u10h(i,j)=u10(i,j)
- end do
- end do
-! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa)
-
-! 10 m v using gfsio
- VarName='vgrd10m'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,v10)
-
- do j=jsta,jend
- do i=1,im
- v10h(i,j)=v10(i,j)
- end do
- end do
-! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa)
-
-! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon
- VarName='vtype'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,buf)
-! where (buf /= spval)
-! ivgtyp=nint(buf)
-! elsewhere
-! ivgtyp=0 !need to feed reasonable value to crtm
-! end where
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- if (buf(i,j) < spval) then
- ivgtyp(i,j) = nint(buf(i,j))
- else
- ivgtyp(i,j) = 0
- endif
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa)
-
-! soil type, it's in GFS surface file, hopefully will merge into gfsio soon
- VarName='sotyp'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,buf)
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- if (buf(i,j) < spval) then
- isltyp(i,j) = nint(buf(i,j))
- else
- isltyp(i,j) = 0 !need to feed reasonable value to crtm
- endif
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa)
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- smstav(i,j) = spval ! GFS does not have soil moisture availability
-! smstot(i,j) = spval ! GFS does not have total soil moisture
- sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation
- acsnow(i,j) = spval ! GFS does not have averaged accumulated snow
- acsnom(i,j) = spval ! GFS does not have snow melt
-! sst(i,j) = spval ! GFS does not have sst????
- thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute
- qz0(i,j) = spval ! GFS does not output humidity at roughness length
- uz0(i,j) = spval ! GFS does not output u at roughness length
- vz0(i,j) = spval ! GFS does not output humidity at roughness length
- enddo
- enddo
- do l=1,lm
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- EL_PBL(i,j,l) = spval ! GFS does not have mixing length
- exch_h(i,j,l) = spval ! GFS does not output exchange coefficient
- enddo
- enddo
- enddo
-! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa)
-
-! retrieve inst convective cloud top, GFS has cloud top pressure instead of index,
-! will need to modify CLDRAD.f to use pressure directly instead of index
-! VarName='pres'
-! VcoordName='convect-cld top'
-! l=1
-! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa)
- VarName='prescnvclt'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,ptop)
-
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- htop(i,j) = spval
- if(ptop(i,j) <= 0.0) ptop(i,j) = spval
- enddo
- enddo
- do j=jsta,jend
- do i=1,im
- if(ptop(i,j) < spval)then
- do l=1,lm
- if(ptop(i,j) <= pmid(i,j,l))then
- htop(i,j) = l
-! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', &
-! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j)
- exit
- end if
- end do
- end if
- end do
- end do
-
-! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index,
-! will need to modify CLDRAD.f to use pressure directly instead of index
- VarName='prescnvclb'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,pbot)
-! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa)
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- hbot(i,j) = spval
- if(pbot(i,j) <= 0.0) pbot(i,j) = spval
- enddo
- enddo
- do j=jsta,jend
- do i=1,im
-! if(.not.lb(i,j))print*,'false bitmask for pbot at '
-! + ,i,j,pbot(i,j)
- if(pbot(i,j) < spval)then
- do l=lm,1,-1
- if(pbot(i,j) >= pmid(i,j,l)) then
- hbot(i,j) = l
-! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', &
-! pbot(i,j),pmid(i,j,l),hbot(i,j)
- exit
- end if
- end do
- end if
- end do
- end do
- if(debugprint)print*,'sample hbot = ',hbot(isa,jsa)
-! retrieve time averaged low cloud top pressure using nemsio
- VarName='pres_avelct'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,ptopl)
-! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa)
-
-! retrieve time averaged low cloud bottom pressure using nemsio
- VarName='pres_avelcb'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,pbotl)
-! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa)
-
-! retrieve time averaged low cloud top temperature using nemsio
- VarName='tmp_avelct'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,Ttopl)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa)
-
-! retrieve time averaged middle cloud top pressure using nemsio
- VarName='pres_avemct'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,ptopm)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa)
-
-! retrieve time averaged middle cloud bottom pressure using nemsio
- VarName='pres_avemcb'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,pbotm)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa)
-
-! retrieve time averaged middle cloud top temperature using nemsio
- VarName='tmp_avemct'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,Ttopm)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa)
-
-! retrieve time averaged high cloud top pressure using nemsio *********
- VarName='pres_avehct'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,ptoph)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa)
-
-! retrieve time averaged high cloud bottom pressure using nemsio
- VarName='pres_avehcb'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,pboth)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa)
-
-! retrieve time averaged high cloud top temperature using nemsio
- VarName='tmp_avehct'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,Ttoph)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa)
-
-! retrieve boundary layer cloud cover using nemsio
- VarName='tcdc_avebndcl'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,pblcfr)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa)
-! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction
-!$omp parallel do private(i,j)
- do j = jsta_2l, jend_2u
- do i=1,im
- if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01
- enddo
- enddo
-
-! retrieve cloud work function
- VarName='cwork_aveclm'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,cldwork)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa)
-
-! accumulated total (base+surface) runoff
- VarName='watr_acc'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,runoff)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) runoff(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa)
-
-! accumulated evaporation of intercepted water
- VarName='ecan_acc'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,tecan)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) tecan(i,j) = spval
- enddo
- enddo
-
-! accumulated plant transpiration
- VarName='etran_acc'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,tetran)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) tetran(i,j) = spval
- enddo
- enddo
-
-! accumulated soil surface evaporation
- VarName='edir_acc'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,tedir)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) tedir(i,j) = spval
- enddo
- enddo
-
-! total water storage in aquifer
- VarName='wa_acc'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,twa)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) twa(i,j) = spval
- enddo
- enddo
-
-! retrieve shelter max temperature using nemsio
- VarName='tmax_max2m'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,maxtshltr)
-
-! retrieve shelter min temperature using nemsio
- VarName='tmin_min2m'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,mintshltr)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', &
-! 1,mintshltr(im/2,(jsta+jend)/2)
-
-! retrieve shelter max RH
-! VarName='rh02max'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxrhshltr)
-
-! retrieve shelter min temperature using nemsio
-! VarName='rh02min'
-! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l &
-! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,minrhshltr)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', &
-! 1,mintshltr(im/2,(jsta+jend)/2)
-
-!$omp parallel do private(i,j)
- do j=jsta_2l,jend_2u
- do i=1,im
- MAXRHSHLTR(i,j) = SPVAL
- MINRHSHLTR(i,j) = SPVAL
- enddo
- enddo
-
-! retrieve ice thickness using nemsio
- VarName='icetk'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,dzice)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa)
-
-! retrieve wilting point using nemsio
- VarName='wilt'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,smcwlt)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) smcwlt(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa)
-
-! retrieve sunshine duration using nemsio
- VarName='sunsd_acc'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,suntime)
-
-! retrieve field capacity using nemsio
- VarName='fldcp'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,fieldcapa)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) fieldcapa(i,j) = spval
- enddo
- enddo
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa)
-
-! retrieve time averaged surface visible beam downward solar flux
- VarName='vbdsf_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avisbeamswin)
- l=1
-
-! retrieve time averaged surface visible diffuse downward solar flux
- VarName='vddsf_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avisdiffswin)
-
-! retrieve time averaged surface near IR beam downward solar flux
- VarName='nbdsf_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,airbeamswin)
-
-! retrieve time averaged surface near IR diffuse downward solar flux
- VarName='nddsf_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,airdiffswin)
-
-! retrieve time averaged surface clear sky outgoing LW
- VarName='csulf'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,alwoutc)
-
-! retrieve time averaged TOA clear sky outgoing LW
- VarName='csulftoa'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,alwtoac)
-
-! retrieve time averaged surface clear sky outgoing SW
- VarName='csusf'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,aswoutc)
-
-! retrieve time averaged TOA clear sky outgoing LW
- VarName='csusftoa'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,aswtoac)
-
-! retrieve time averaged surface clear sky incoming LW
- VarName='csdlf'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,alwinc)
-
-! retrieve time averaged surface clear sky incoming SW
- VarName='csdsf'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,aswinc)
-
-! retrieve shelter max specific humidity using nemsio
- VarName='spfhmax_max2m'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,maxqshltr)
-! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',
-! 1,maxqshltr(isa,jsa)
-
-! retrieve shelter min temperature using nemsio
- VarName='spfhmin_min2m'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,minqshltr)
-
-! retrieve storm runoff using nemsio
- VarName='ssrun_acc'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,SSROFF)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) ssroff(i,j) = spval
- enddo
- enddo
-
-! retrieve direct soil evaporation
- VarName='evbs_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgedir)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) avgedir(i,j) = spval
- enddo
- enddo
-
-! retrieve CANOPY WATER EVAP
- VarName='evcw_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgecan)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) avgecan(i,j) = spval
- enddo
- enddo
-
-! retrieve AVERAGED PRECIP ADVECTED HEAT FLUX
- VarName='pah_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,paha)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) paha(i,j) = spval
- enddo
- enddo
-
-! retrieve nstantaneous PRECIP ADVECTED HEAT FLUX
- VarName='pahi'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,pahi)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) pahi(i,j) = spval
- enddo
- enddo
-
-! retrieve PLANT TRANSPIRATION
- VarName='trans_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgetrans)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) avgetrans(i,j) = spval
- enddo
- enddo
-
-! retrieve snow sublimation
- VarName='sbsno_ave'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,avgesnow)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval
- enddo
- enddo
-
-! retrive total soil moisture
- VarName='soilm'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,smstot)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) smstot(i,j) = spval
- enddo
- enddo
-
-! retrieve snow phase change heat flux
- VarName='snohf'
- call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,snopcx)
-! mask water areas
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- if (sm(i,j) /= 0.0) snopcx(i,j) = spval
- enddo
- enddo
-
-! GFS does not have deep convective cloud top and bottom fields
-
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- HTOPD(i,j) = SPVAL
- HBOTD(i,j) = SPVAL
- HTOPS(i,j) = SPVAL
- HBOTS(i,j) = SPVAL
- CUPPT(i,j) = SPVAL
- enddo
- enddo
-
-! done with flux file, close it for now
- Status=nf90_close(ncid2d)
-! deallocate(tmp,recname,reclevtyp,reclev)
-
-! pos east
-! call collect_loc(gdlat,dummy)
-! if(me == 0)then
-! latstart = nint(dummy(1,1)*gdsdegr)
-! latlast = nint(dummy(im,jm)*gdsdegr)
-! print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,&
-! 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1)
-! end if
-! call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn)
-! call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn)
-! write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me
-! call collect_loc(gdlon,dummy)
-! if(me == 0)then
-! lonstart = nint(dummy(1,1)*gdsdegr)
-! lonlast = nint(dummy(im,jm)*gdsdegr)
-! end if
-! call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn)
-! call mpi_bcast(lonlast, 1,MPI_INTEGER,0,mpi_comm_comp,irtn)
-
-! write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast
-!
-
-! generate look up table for lifted parcel calculations
-
- THL = 210.
- PLQ = 70000.
- pt_TBL = 10000. ! this is for 100 hPa added by Moorthi
-
- CALL TABLE(PTBL,TTBL,PT_TBL, &
- RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0)
-
- CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q)
-
-!
-!
- IF(ME == 0)THEN
- WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: '
- WRITE(6,51) (SPL(L),L=1,LSM)
- 50 FORMAT(14(F4.1,1X))
- 51 FORMAT(8(F8.1,1X))
- ENDIF
-!
-!$omp parallel do private(l)
- DO L = 1,LSM
- ALSL(L) = LOG(SPL(L))
- END DO
-!
-!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN
- if(me == 0)then
- print*,'writing out igds'
- igdout = 110
-! open(igdout,file='griddef.out',form='unformatted'
-! + ,status='unknown')
- if(maptype == 1)THEN ! Lambert conformal
- WRITE(igdout)3
- WRITE(6,*)'igd(1)=',3
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)8
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)0
- WRITE(igdout)64
- WRITE(igdout)TRUELAT2
- WRITE(igdout)TRUELAT1
- WRITE(igdout)255
- ELSE IF(MAPTYPE == 2)THEN !Polar stereographic
- WRITE(igdout)5
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)8
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)0
- WRITE(igdout)64
- WRITE(igdout)TRUELAT2 !Assume projection at +-90
- WRITE(igdout)TRUELAT1
- WRITE(igdout)255
- ! Note: The calculation of the map scale factor at the standard
- ! lat/lon and the PSMAPF
- ! Get map factor at 60 degrees (N or S) for PS projection, which will
- ! be needed to correctly define the DX and DY values in the GRIB GDS
- if (TRUELAT1 < 0.) THEN
- LAT = -60.
- else
- LAT = 60.
- end if
-
- CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF)
-
- ELSE IF(MAPTYPE == 3) THEN !Mercator
- WRITE(igdout)1
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)8
- WRITE(igdout)latlast
- WRITE(igdout)lonlast
- WRITE(igdout)TRUELAT1
- WRITE(igdout)0
- WRITE(igdout)64
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)255
- ELSE IF(MAPTYPE == 0 .OR. MAPTYPE == 203)THEN !A STAGGERED E-GRID
- WRITE(igdout)203
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)136
- WRITE(igdout)CENLAT
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)64
- WRITE(igdout)0
- WRITE(igdout)0
- WRITE(igdout)0
- END IF
- end if
-!
-!
-
- RETURN
- END
-
- subroutine read_netcdf_3d_para(ncid,im,jm,jsta,jsta_2l,jend,jend_2u, &
- spval,varname,buf,lm)
-
- use netcdf
- implicit none
- INCLUDE "mpif.h"
-
- character(len=20),intent(in) :: varname
- real,intent(in) :: spval
- integer,intent(in) :: ncid,im,jm,lm,jsta_2l,jend_2u,jsta,jend
- real,intent(out) :: buf(im,jsta_2l:jend_2u,lm)
- integer :: varid,iret,jj,i,j,l,kk
- integer :: start(3), count(3), stride(3)
-
- iret = nf90_inq_varid(ncid,trim(varname),varid)
- if (iret /= 0) then
- print*,VarName," not found -Assigned missing values"
-!$omp parallel do private(i,j,l)
- do l=1,lm
- do j=jsta,jend
- do i=1,im
- buf(i,j,l)=spval
- enddo
- enddo
- enddo
- else
- start = (/1,jsta,1/)
- jj=jend-jsta+1
- count = (/im,jj,lm/)
- iret = nf90_get_var(ncid,varid,buf(1:im,jsta:jend,1:lm),start=start,count=count)
- endif
-
- end subroutine read_netcdf_3d_para
-
- subroutine read_netcdf_2d_para(ncid,im,jsta,jsta_2l,jend,jend_2u, &
- spval,VarName,buf)
-
- use netcdf
- implicit none
- INCLUDE "mpif.h"
-
- character(len=20),intent(in) :: VarName
- real,intent(in) :: spval
- integer,intent(in) :: ncid,im,jsta_2l,jend_2u,jsta,jend
- real,intent(out) :: buf(im,jsta_2l:jend_2u)
- integer :: varid,iret,jj,i,j
- integer :: start(2), count(2)
-
- iret = nf90_inq_varid(ncid,trim(varname),varid)
- if (iret /= 0) then
- print*,VarName," not found -Assigned missing values"
-!$omp parallel do private(i,j)
- do j=jsta,jend
- do i=1,im
- buf(i,j)=spval
- enddo
- enddo
- else
- start = (/1,jsta/)
- jj=jend-jsta+1
- count = (/im,jj/)
- iret = nf90_get_var(ncid,varid,buf(:,jsta),start=start,count=count)
- endif
-
- end subroutine read_netcdf_2d_para
diff --git a/sorc/ncep_post.fd/INITPOST_NEMS.f b/sorc/ncep_post.fd/INITPOST_NEMS.f
index 39459701f..a88dfa3d6 100644
--- a/sorc/ncep_post.fd/INITPOST_NEMS.f
+++ b/sorc/ncep_post.fd/INITPOST_NEMS.f
@@ -1,39 +1,22 @@
!> @file
-! . . .
-!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN
-!! PRGRMMR: Hui-Ya Chuang DATE: 2008-03-26
-!!
-!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND
-!! VARIABLES AT THE START OF AN NEMS MODEL OR POST
-!! PROCESSOR RUN.
-!!
-!! REVISION HISTORY
-!! 21-03-11 Bo Cui - change local arrays to dimension (im,jsta:jend)
-!!
-!! USAGE: CALL INITPOST_NEMS
-!! INPUT ARGUMENT LIST:
-!! NREC
-!! NFILE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! NONE
-!! LIBRARY:
-!! COMMON - CTLBLK
-!! LOOKUP
-!! SOILDEPTH
-!!
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
+!> @brief initpost_nems() initializes post for run.
+!>
+!> @author Hui-Ya Chuang @date 2007-03-26
+
+!> This routine initializes constants and
+!> variables at the start of an NEMS model or post
+!> processor run.
+!>
+!> @param[in] NREC.
+!> @param[in] NFILE.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2007-03-01 | Hui-Ya Chuang | Initial
+!> 2021-03-11 | Bo Cui | Change local arrays to dimension (im,jsta:jend)
+!>
+!> @author Hui-Ya Chuang @date 2007-03-26
SUBROUTINE INITPOST_NEMS(NREC,nfile)
use vrbls3d, only: t, q, uh, vh, q2, cwm, f_ice, f_rain, f_rimef, cfr, pint,&
diff --git a/sorc/ncep_post.fd/INITPOST_NEMS_MPIIO.f b/sorc/ncep_post.fd/INITPOST_NEMS_MPIIO.f
deleted file mode 100644
index 9aed1706b..000000000
--- a/sorc/ncep_post.fd/INITPOST_NEMS_MPIIO.f
+++ /dev/null
@@ -1,2464 +0,0 @@
-!> @file
-! . . .
-!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN
-!! PRGRMMR: Hui-Ya Chuang DATE: 2008-03-26
-!!
-!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND
-!! VARIABLES AT THE START OF AN NEMS MODEL OR POST
-!! PROCESSOR RUN.
-!!
-!! REVISION HISTORY
-!! 21-03-11 Bo Cui - change local arrays to dimension (im,jsta:jend)
-!!
-!! USAGE: CALL INITPOST_NEMS
-!! INPUT ARGUMENT LIST:
-!! NREC
-!! NFILE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! NONE
-!! LIBRARY:
-!! COMMON - CTLBLK
-!! LOOKUP
-!! SOILDEPTH
-!!
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
- SUBROUTINE INITPOST_NEMS_MPIIO()
-
- use vrbls3d, only: t, q, uh, vh, q2, cwm, f_ice, f_rain, f_rimef, cfr, pint,&
- pint, alpint, pmid, pmidv, zint, zmid, wh, rlwtt, rswtt,&
- ttnd, tcucn, train, el_pbl, exch_h, omga
- use vrbls2d, only: f, pd, fis, pblh, mixht, ustar, z0, ths, qs, twbs, qwbs, prec,&
- acprec, cuprec,ancprc, lspa, sno, snoavg, psfcavg, t10avg, t10m, akhsavg, akmsavg,&
- refd_max, w_up_max, w_dn_max, up_heli_max, si, cldefi, th10, q10, pshltr,&
- tshltr, qshltr, maxtshltr, mintshltr, maxrhshltr, minrhshltr, akhs, akms, albase,&
- albedo, czen, cfracl, cfracm, islope, cmc, grnflx, pctsno, soiltb, vegfrc,&
- acfrcv, acfrst, ssroff, bgroff, czmean, mxsnal, radot, sigt4, tg, sr, cfrach,&
- rlwin, rlwtoa, alwin, alwout, alwtoa, rswin, rswinc, rswout, aswin,aswout,&
- aswtoa, sfcshx, sfclhx, subshx, snopcx, sfcuvx, potevp, ncfrcv, ncfrst, u10h,&
- u10, v10h, v10, u10max, v10max, smstav, smstot, sfcevp, ivgtyp, acsnow, acsnom,&
- sst, thz0, qz0, uz0, vz0, htop, isltyp, sfcexc, hbot, htopd, htops, cuppt, cprate,&
- hbotd, hbots
- use soil, only: sldpth, sh2o, smc, stc
- use masks, only: lmv, lmh, htm, vtm, dx, dy, hbm2, gdlat, gdlon, sm, sice
- use kinds, only: i_llong
- use wrf_io_flags_mod, only:
- use params_mod, only: pi, dtr, g, d608, rd
- use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, the0,&
- ttblq, rdpq, rdtheq, stheq, the0q
- use ctlblk_mod, only: me, mpi_comm_comp, global, icnt, idsp, jsta, ihrst, imin, idat, sdat,&
- ifhr, ifmin, filename, restrt, imp_physics, isf_surface_physics, icu_physics, jend,&
- dt, spval, gdsdegr, grib, pdtop, pt, tmaxmin, nsoil, lp1, jend_m, nprec, nphs, avrain,&
- avcnvc, ardlw, ardsw, asrfc, novegtype, spl, lsm, dtq2, tsrfc, trdlw, trdsw, theat, tclod,&
- tprec, alsl, lm , im, jm, jsta_2l, jend_2u, ivegsrc, pthresh
- use gridspec_mod, only: dyval, dxval, cenlat, cenlon, maptype, gridtype, latstart, latlast, latnw,&
- latse, lonstart, lonlast, lonnw, lonse, latstartv, latlastv, cenlatv, lonstartv,&
- lonlastv, cenlonv
-! use nemsio_module, only: nemsio_gfile, nemsio_getfilehead, nemsio_close, nemsio_getheadvar
- use nemsio_module_mpi
- use upp_math, only: h2u
-!
-! INCLUDE/SET PARAMETERS.
- implicit none
-!
- type(nemsio_gfile) :: nfile
-!
- INCLUDE "mpif.h"
-! This version of INITPOST shows how to initialize, open, read from, and
-! close a NetCDF dataset. In order to change it to read an internal (binary)
-! dataset, do a global replacement of _ncd_ with _int_.
-
- character(len=8) :: VarName
- character(len=8) :: VcoordName
- integer :: Status
- integer fldsize,fldst,recn
- character startdate*19,SysDepInfo*80,cgar*1
- character startdate2(19)*4
-!
-! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK
-! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE.
-!
-! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE
-! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE.
- LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO
- LOGICAL IOOMG,IOALL
- logical, parameter :: debugprint = .false.
- logical fliplayer ! whether or not to flip layer
- logical :: convert_rad_to_deg=.false.
-! logical global
- CHARACTER*32 LABEL
- CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV &
- , FILCLD,FILRAD,FILSFC
- CHARACTER*4 RESTHR
- CHARACTER FNAME*80,ENVAR*50,BLANK*4
- integer nfhour ! forecast hour from nems io file
- INTEGER IDATE(8),JDATE(8)
-!
-! DECLARE VARIABLES.
-!
- REAL FACT,tsph,tstart
- REAL RINC(5)
- REAL ETA1(LM+1), ETA2(LM+1)
- REAL GARB
- REAL DUM1D (LM+1)
- REAL DUMMY ( IM, JM )
-! REAL DUMMY2 ( IM, JM )
- real, allocatable :: fi(:,:,:)
- integer ibuf(im,jsta_2l:jend_2u)
- real buf(im,jsta_2l:jend_2u)
- character*8,allocatable:: recname(:)
- character*8,allocatable :: reclevtyp(:)
- integer,allocatable:: reclev(:)
- real, allocatable:: bufy(:)
- real, allocatable:: glat1d(:),glon1d(:)
- real, allocatable:: tmp(:)
-!jw
- integer ii,jj,js,je,jev,iyear,imn,iday,itmp,ioutcount,istatus, &
- nsrfc,nrdlw,nrdsw,nheat,nclod, &
- iunit,nrec,I,J,L, iret,nframe,impf,jmpf,nframed2, &
- igdout,ll,n,im1,jm1,iim1
-!
- DATA BLANK/' '/
-!
-!***********************************************************************
-! START INIT HERE.
-!
- WRITE(6,*)'INITPOST: ENTER INITPOST'
-!
-!
-! STEP 1. READ MODEL OUTPUT FILE
-!
-!***
-! LMH always = LM for sigma-type vert coord
-! LMV always = LM for sigma-type vert coord
-
- do j = jsta_2l, jend_2u
- do i = 1, im
- LMV ( i, j ) = lm
- LMH ( i, j ) = lm
- end do
- end do
-
-! HTM VTM all 1 for sigma-type vert coord
-
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- HTM ( i, j, l ) = 1.0
- VTM ( i, j, l ) = 1.0
- end do
- end do
- end do
-
-! The end j row is going to be jend_2u for all variables except for V.
- JS=JSTA_2L
- JE=JEND_2U
- IF (JEND_2U==JM) THEN
- JEV=JEND_2U+1
- ELSE
- JEV=JEND_2U
- ENDIF
-! sample print point
- ii=(1+im)/2
- jj=(1+jm)/2
-! initialize nemsio using mpi io module
- call nemsio_init()
- call nemsio_open(nfile,trim(filename),'read',mpi_comm_comp,iret=status)
- if ( Status /= 0 ) then
- print*,'error opening ',fileName, ' Status = ', Status ; stop
- endif
- call nemsio_getfilehead(nfile,iret=status,nrec=nrec)
- print*,'nrec=',nrec
- allocate(recname(nrec),reclevtyp(nrec),reclev(nrec))
- call nemsio_getfilehead(nfile,iret=iret &
- ,recname=recname ,reclevtyp=reclevtyp,reclev=reclev)
- if (me == 0)then
- do i=1,nrec
- print *,'recname,reclevtyp,reclev=',trim(recname(i)),' ', &
- trim(reclevtyp(i)),reclev(i)
- end do
- end if
-
-! get start date
- idate=0
-! if (me == 0)then
- call nemsio_getfilehead(nfile,iret=iret &
- ,idate=idate(1:7),nfhour=nfhour,nframe=nframe)
-
- impf=im+nframe*2
- jmpf=jm+nframe*2
- print*,'nframe,impf,jmpf= ',nframe,impf,jmpf
- allocate(glat1d(impf*jmpf),glon1d(impf*jmpf) )
- call nemsio_getfilehead(nfile,dx=glat1d &
- ,dy=glon1d,iret=iret)
- if(iret/=0)print*,'did not find dx dy'
- do j=jsta,jend
- do i=1,im
- ! dummy(i,j) = glat1d((j-1)*impf+i+nframe)
- ! dummy2(i,j) = glon1d((j-1)*impf+i+nframe)
- dx(i,j)= glat1d((j-1)*impf+i+nframe)
- dy(i,j)= glon1d((j-1)*impf+i+nframe)
- end do
- end do
- deallocate(glat1d,glon1d)
- print*,'idate before broadcast = ',(idate(i),i=1,7)
-! end if !for me=0
-! call mpi_bcast(idate(1),7,MPI_INTEGER,0,mpi_comm_comp,iret)
-! call mpi_bcast(nfhour,1,MPI_INTEGER,0,mpi_comm_comp,iret)
-! call mpi_bcast(nframe,1,MPI_INTEGER,0,mpi_comm_comp,iret)
-
- IF(.not. global)THEN
- impf=im+nframe*2
- jmpf=jm+nframe*2
- ELSE
- impf=im+1 ! post cut im off because it's the same as i=1 but data from model is till im
- jmpf=jm
- END IF
- print*,'impf,jmpf,nframe for reading fields = ',impf,jmpf,nframe
- print*,'idate after broadcast = ',(idate(i),i=1,7)
- print*,'nfhour = ',nfhour
- !call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real &
- ! ,dx(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret)
- !call mpi_scatterv(dummy2(1,1),icnt,idsp,mpi_real &
- ! ,dy(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret)
-
-
- iyear = idate(1)
- imn = idate(2) ! ask Jun
- iday = idate(3) ! ask Jun
- ihrst = idate(4)
- imin = idate(5)
- jdate = 0
- idate = 0
-!
-! read(startdate,15)iyear,imn,iday,ihrst,imin
- 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2)
- print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin
- print*,'processing yr mo day hr min=' &
- ,idat(3),idat(1),idat(2),idat(4),idat(5)
-!
- idate(1) = iyear
- idate(2) = imn
- idate(3) = iday
- idate(5) = ihrst
- idate(6) = imin
- SDAT(1) = imn
- SDAT(2) = iday
- SDAT(3) = iyear
- jdate(1) = idat(3)
- jdate(2) = idat(1)
- jdate(3) = idat(2)
- jdate(5) = idat(4)
- jdate(6) = idat(5)
-!
- print *,' idate=',idate
- print *,' jdate=',jdate
-! CALL W3DIFDAT(JDATE,IDATE,2,RINC)
-! ifhr=nint(rinc(2))
-!
- CALL W3DIFDAT(JDATE,IDATE,0,RINC)
-!
- print *,' rinc=',rinc
- ifhr=nint(rinc(2)+rinc(1)*24.)
- print *,' ifhr=',ifhr
- ifmin=nint(rinc(3))
-! if(ifhr /= nfhour)print*,'find wrong Model input file';stop
- print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,fileName
-
-! Getting tstart
- tstart=0.
- print*,'tstart= ',tstart
-
-! Getiing restart
-
- RESTRT=.TRUE. ! set RESTRT as default
-! call ext_int_get_dom_ti_integer(DataHandle,'RESTARTBIN',itmp
-! + ,1,ioutcount,istatus)
-
-! IF(itmp < 1)THEN
-! RESTRT=.FALSE.
-! ELSE
-! RESTRT=.TRUE.
-! END IF
-
-! print*,'status for getting RESTARTBIN= ',istatus
-
-! print*,'Is this a restrt run? ',RESTRT
-
- IF(tstart > 1.0E-2)THEN
- ifhr=ifhr+NINT(tstart)
- rinc=0
- idate=0
- rinc(2)=-1.0*ifhr
- call w3movdat(rinc,jdate,idate)
- SDAT(1)=idate(2)
- SDAT(2)=idate(3)
- SDAT(3)=idate(1)
- IHRST=idate(5)
- print*,'new forecast hours for restrt run= ',ifhr
- print*,'new start yr mo day hr min =',sdat(3),sdat(1) &
- ,sdat(2),ihrst,imin
- END IF
-
- VarName='mp_physi'
- !if(me == 0)then
- call nemsio_getheadvar(nfile,trim(VarName),imp_physics,iret)
- if (iret /= 0) then
- print*,VarName," not found in file- go to 16 character "
- VarName='mp_physics'
- call nemsio_getheadvar(nfile,trim(VarName),imp_physics,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned 1000"
- imp_physics=1000
- end if
- end if
- !end if
- !call mpi_bcast(imp_physics,1,MPI_INTEGER,0,mpi_comm_comp,iret)
- print*,'MP_PHYSICS= ',imp_physics
-
-! Initializes constants for Ferrier microphysics
- if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then
- CALL MICROINIT(imp_physics)
- end if
-
- VarName='sf_surface_physi'
- call nemsio_getheadvar(nfile,trim(VarName),iSF_SURFACE_PHYSICS,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned 2 for NOAH LSM as default"
- iSF_SURFACE_PHYSICS=2
- end if
- print*,'SF_SURFACE_PHYSICS= ',iSF_SURFACE_PHYSICS
-
-! IVEGSRC=1 for IGBP and 0 for USGS
- VarName='IVEGSRC'
- call nemsio_getheadvar(nfile,trim(VarName),IVEGSRC,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned 1 for IGBP as default"
- IVEGSRC=1
- end if
- print*,'IVEGSRC= ',IVEGSRC
-
-! set novegtype based on vegetation classification
- if(ivegsrc==1)then
- novegtype=20
- else if(ivegsrc==0)then
- novegtype=24
- end if
- print*,'novegtype= ',novegtype
-
- VarName='CU_PHYSICS'
- call nemsio_getheadvar(nfile,trim(VarName),iCU_PHYSICS,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned 2 for BMJ as default"
- iCU_PHYSICS=2
- end if
- print*,'CU_PHYSICS= ',iCU_PHYSICS
-
-
- allocate(bufy(jm))
- VarName='DX'
-! if(me == 0)then
-! call nemsio_getheadvar(nfile,trim(VarName),bufy,iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! dx=spval
-! end if
-! end if
-! call mpi_bcast(bufy,jm,MPI_REAL,0,mpi_comm_comp,iret)
-! do j=jsta,jend
-! do i=1,im
-! dx(i,j)=bufy(j)
-! end do
-! end do
- if(debugprint)print*,'sample ',VarName,' = ',dx(im/2,(jsta+jend)/2)
-
- VarName='DY'
-! if(me == 0)then
-! call nemsio_getheadvar(nfile,trim(VarName),bufy,iret)
-! if (iret /= 0) then
-! print*,VarName," not found in file-Assigned missing values"
-! dx=spval
-! end if
-! end if
-! call mpi_bcast(bufy,jm,MPI_REAL,0,mpi_comm_comp,iret)
-! do j=jsta,jend
-! do i=1,im
-! dy(i,j)=bufy(j)
-! end do
-! end do
- if(debugprint)print*,'sample ',VarName,' = ',dy(im/2,(jsta+jend)/2)
- deallocate(bufy)
-
- VarName='dt'
- call nemsio_getheadvar(nfile,trim(VarName),garb,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned missing values"
- dt=spval
- else
- dt=garb
- end if
-
- VarName='dphd'
- call nemsio_getheadvar(nfile,trim(VarName),garb,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned missing values"
- dyval=spval
- else
- dyval=garb*gdsdegr
- end if
-! dyval=106 ! hard wire for AQ domain testing
-
- VarName='dlmd'
- call nemsio_getheadvar(nfile,trim(VarName),garb,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned missing values"
- dxval=spval
- else
- dxval=garb*gdsdegr
- end if
-! dxval=124 ! hard wire for AQ domain testing
-
- print*,'DX, DY, DT=',dxval,dyval,dt
-
- VarName='TPH0D'
- call nemsio_getheadvar(nfile,trim(VarName),garb,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned missing values"
- cenlat=spval
- else
- cenlat=nint(garb*gdsdegr)
- end if
-
- VarName='TLM0D'
- call nemsio_getheadvar(nfile,trim(VarName),garb,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned missing values"
- cenlon=spval
- else
- if(grib=="grib2") then
- cenlon=nint((garb+360.)*gdsdegr)
- endif
- end if
-
- varname='sg1'
- call nemsio_getheadvar(nfile,trim(varname),eta1,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned missing values"
- ETA1=SPVAL
- end if
-
- varname='sg2'
- call nemsio_getheadvar(nfile,trim(varname),eta2,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned missing values"
- ETA2=SPVAL
- end if
- if(me==0)then
- open(75,file='ETAPROFILE.txt',form='formatted', &
- status='unknown')
- DO L=1,lm+1
- write(75,1020)L, ETA1(lm+2-l), ETA2(lm+2-l)
- END DO
- 1020 format(I3,2E17.10)
- close (75)
- end if
-
- varname='pdtop'
- call nemsio_getheadvar(nfile,trim(varname),pdtop,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned missing values"
- pdtop=SPVAL
- end if
-
- varname='pt'
- call nemsio_getheadvar(nfile,trim(varname),pt,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned missing values"
- pt=SPVAL
- end if
- print*,'PT, PDTOP= ',PT,PDTOP
-
- VarName='sldpth'
- call nemsio_getheadvar(nfile,trim(varname),sldpth,iret)
- print*,'SLDPTH= ',(SLDPTH(N),N=1,NSOIL)
-
-! set default to not empty buket
- nprec=0
- nphs=0
- nclod=0
- nheat=0
- nrdlw=0
- nrdsw=0
- nsrfc=0
-
- VarName='nprec'
- call nemsio_getheadvar(nfile,trim(varname),nprec,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned zero"
- end if
- if(debugprint)print*,'sample ',VarName,' = ',nprec
-
- VarName='nphs'
- call nemsio_getheadvar(nfile,trim(varname),nphs,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned zero"
- end if
- if(debugprint)print*,'sample ',VarName,' = ',nphs
-
- VarName='nclod'
- call nemsio_getheadvar(nfile,trim(varname),nclod,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned zero"
- end if
- if(debugprint)print*,'sample ',VarName,' = ',nclod
-
- VarName='nheat'
- call nemsio_getheadvar(nfile,trim(varname),nheat,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned zero"
- end if
- if(debugprint)print*,'sample ',VarName,' = ',nheat
-
- VarName='nrdlw'
- call nemsio_getheadvar(nfile,trim(varname),nrdlw,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned zero"
- end if
- if(debugprint)print*,'sample ',VarName,' = ',nrdlw
-
- VarName='nrdsw'
- call nemsio_getheadvar(nfile,trim(varname),nrdsw,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned zero"
- end if
- if(debugprint)print*,'sample ',VarName,' = ',nrdsw
-
- VarName='nsrfc'
- call nemsio_getheadvar(nfile,trim(varname),nsrfc,iret)
- if (iret /= 0) then
- print*,VarName," not found in file-Assigned zero"
- end if
- if(debugprint)print*,'sample ',VarName,' = ',nsrfc
-
- IF(.not. global)THEN
- maptype=205 ! for Arakawa-B grid
- gridtype='B'
- ELSE
- maptype=0 ! for global NMMB on latlon grid
- gridtype='A' ! will put wind on mass point for now to make regular latlon
- END IF
- print*,'maptype and gridtype= ',maptype,gridtype
-
- HBM2=1.0
-
-! start reading nemsio files using parallel read
- fldsize=(jend-jsta+1)*im
- allocate(tmp(fldsize*nrec))
- print*,'allocate tmp successfully'
- tmp=0.
- call nemsio_denseread(nfile,1,im,jsta,jend,tmp,iret=iret)
- if(iret/=0)then
- print*,"fail to read nemsio file using mpi io read, stopping"
- stop
- end if
-
- varname='glat'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,gdlat)
-
- call collect_loc(gdlat,dummy)
-! decides whether or not to convert to degree
- if(me==0)then
- if(maxval(abs(dummy))0. .and. gdlon(2,jsta)<0.)then
- do j=jsta,jend
- gdlon(1,j)=gdlon(1,j)-360.0
- end do
- end if
- end if
- if(debugprint)print*,'sample ',VarName,' = ',(gdlon(i,(jsta+jend)/2),i=1,im,8)
- if(debugprint)print*,'max min lon=',maxval(gdlon),minval(gdlon)
- call collect_loc(gdlon,dummy)
- if(me==0)then
- if(grib=='grib2') then
- if(dummy(1,1)<0) dummy(1,1)=dummy(1,1)+360.
- if(dummy(im,jm)<0) dummy(im,jm)=dummy(im,jm)+360.
- endif
- lonstart=nint(dummy(1,1)*gdsdegr)
- lonlast=nint(dummy(im,jm)*gdsdegr)
- lonnw=nint(dummy(1,jm)*gdsdegr)
- lonse=nint(dummy(im,1)*gdsdegr)
-! dxval=nint((dummy(2,1)-dummy(1,1))*1000.)
-! dxval=124 ! hard wire for AQ domain testing
- if(mod(im,2)==0)then
-! cenlon=nint((dummy(ii,jj)+dummy(ii+1,jj)+dummy(ii+1,jj+1)+dummy(ii,jj+1))/4.0*1000.)
- else
-! cenlon=nint(dummy(ii,jj)*1000.)
- end if
- end if
- call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,iret)
- call mpi_bcast(lonlast,1,MPI_INTEGER,0,mpi_comm_comp,iret)
-! call mpi_bcast(dxval,1,MPI_INTEGER,0,mpi_comm_comp,iret)
-! call mpi_bcast(cenlon,1,MPI_INTEGER,0,mpi_comm_comp,iret)
- write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast
- print*,'dxval, cenlon= ',dxval, cenlon
-
- convert_rad_to_deg=.false.
- varname='vlat'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,buf)
-
- if(debugprint)print*,'sample ',VarName,' = ',buf(im/2,(jsta+jend)/2)
- if(debugprint)print*,'max min vlat=',maxval(buf),minval(buf)
- call collect_loc(buf,dummy)
- if(me==0)then
- if(maxval(abs(dummy)) 27.0 .or. sfcevp(i,j)<1.0)print*, &
-! 'bad vegtype=',i,j,sfcevp(i,j)
-! end do
-! end do
-
- where(sfcevp /= spval)IVGTYP=nint(sfcevp)
- if(debugprint)print*,'sample ',VarName,' = ',IVGTYP(im/2,(jsta+jend)/2)
-
- sfcevp=spval
- VarName='sltyp'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,sfcevp) ! temporary use sfcevp because it's real in nemsio
- where(sfcevp /= spval)ISLTYP=nint(sfcevp)
- if(debugprint)print*,'sample ',VarName,' = ',ISLTYP(im/2,(jsta+jend)/2)
-
- sfcevp=spval
- VarName='sfcevp'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,sfcevp)
- if(debugprint)print*,'sample ',VarName,' = ',sfcevp(im/2,(jsta+jend)/2)
-
- VarName='sfcexc'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,sfcexc)
- if(debugprint)print*,'sample ',VarName,' = ',sfcexc(im/2,(jsta+jend)/2)
- if(debugprint)print*,'MAX/MIN ',VarName,' = ' &
- ,maxval(sfcexc),minval(sfcexc)
-
- VarName='acsnow'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,acsnow)
- if(debugprint)print*,'sample ',VarName,' = ',acsnow(im/2,(jsta+jend)/2)
-
- VarName='acsnom'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,acsnom)
- if(debugprint)print*,'sample ',VarName,' = ',acsnom(im/2,(jsta+jend)/2)
-
- VarName='tsea'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,sst)
- if(debugprint)print*,'sample ',VarName,' = ',sst(im/2,(jsta+jend)/2)
-
-! VarName='EL_PBL' ! not in nems io yet
- VarName='xlen_mix'
- VcoordName='mid layer'
- do l=1,lm
-! ll=lm-l+1
- ll=l
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,ll,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,EL_PBL(1,jsta_2l,ll))
- if(debugprint)print*,'sample l ',VarName,' = ',ll,EL_PBL(im/2,(jsta+jend)/2,ll)
- end do ! do loop for l
-
- VarName='exch_h'
- VcoordName='mid layer'
- do l=1,lm
-! ll=lm-l+1
- ll=l
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,ll,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,exch_h(1,jsta_2l,ll))
- if(debugprint)print*,'sample l ',VarName,' = ',ll,exch_h(im/2,(jsta+jend)/2,ll)
- end do ! do loop for l
-
- VarName='thz0'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,thz0)
- if(debugprint)print*,'sample ',VarName,' = ',thz0(im/2,(jsta+jend)/2)
-
- VarName='qz0'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,qz0)
- if(debugprint)print*,'sample ',VarName,' = ',qz0(im/2,(jsta+jend)/2)
-
- VarName='uz0'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,uz0)
- if(debugprint)print*,'sample ',VarName,' = ',uz0(im/2,(jsta+jend)/2)
-
- VarName='vz0'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,vz0)
- if(debugprint)print*,'sample ',VarName,' = ',vz0(im/2,(jsta+jend)/2)
-
-!
-! Very confusing story ...
-!
-! Retrieve htop and hbot => They are named CNVTOP, CNVBOT in the model and
-! with HBOTS,HTOPS (shallow conv) and HBOTD,HTOPD (deep conv) represent
-! the 3 sets of convective cloud base/top arrays tied to the frequency
-! that history files are written.
-!
-! IN THE *MODEL*, arrays HBOT,HTOP are similar to CNVTOP,CNVBOT but are
-! used in radiation and are tied to the frequency of radiation updates.
-!
-! For historical reasons model arrays CNVTOP,CNVBOT are renamed HBOT,HTOP
-! and manipulated throughout the post.
-
-! retrieve htop and hbot
-! VarName='HTOP'
- VarName='cnvtop'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,htop)
- where(htop /= spval)htop=float(lm)-htop+1.0
-! where(htop /= spval .and. htop > lm)htop=lm*1.0
- if(debugprint)print*,'sample ',VarName,' = ',htop(im/2,(jsta+jend)/2)
-
-! VarName='HBOT'
- VarName='cnvbot'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,hbot)
- where(hbot /= spval)hbot=float(lm)-hbot+1.0
-! where(hbot /= spval .and. hbot > lm)hbot=lm*1.0
- if(debugprint)print*,'sample ',VarName,' = ',hbot(im/2,(jsta+jend)/2)
-
- VarName='htopd'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,htopd)
- where(htopd /= spval)htopd=float(lm)-htopd+1.0
-! where(htopd /= spval .and. htopd > lm)htopd=lm*1.0
- if(debugprint)print*,'sample ',VarName,' = ',htopd(im/2,(jsta+jend)/2)
-
- VarName='hbotd'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,hbotd)
- where(hbotd /= spval)hbotd=float(lm)-hbotd+1.0
-! where(hbotd /= spval .and. hbotd > lm)hbotd=lm*1.0
- if(debugprint)print*,'sample ',VarName,' = ',hbotd(im/2,(jsta+jend)/2)
-
- VarName='htops'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,htops)
- where(htops /= spval)htops=float(lm)-htops+1.0
-! where(htops /= spval .and. htops > lm)htops=lm*1.0
- if(debugprint)print*,'sample ',VarName,' = ',htops(im/2,(jsta+jend)/2)
-
- VarName='hbots'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,hbots)
- where(hbots /= spval)hbots=float(lm)-hbots+1.0
-! where(hbots /= spval .and. hbots > lm)hbots=lm*1.0
- if(debugprint)print*,'sample ',VarName,' = ',hbots(im/2,(jsta+jend)/2)
-
- VarName='cuppt'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,cuppt)
- if(debugprint)print*,'sample ',VarName,' = ',cuppt(im/2,(jsta+jend)/2)
-
- VarName='cprate'
- VcoordName='sfc'
- l=1
- call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
- ,l,nrec,fldsize,spval,tmp &
- ,recname,reclevtyp,reclev,VarName,VcoordName &
- ,cprate)
- if(debugprint)print*,'sample ',VarName,' = ',cprate(im/2,(jsta+jend)/2)
-
- deallocate(tmp,recname,reclevtyp,reclev)
-!!!! DONE GETTING
-
- do l = 1, lm
- do j = jsta, jend
- do i = 1, im
- IF(ABS(T(I,J,L))>1.0E-3) &
- OMGA(I,J,L) = -WH(I,J,L)*PMID(I,J,L)*G/ &
- (RD*T(I,J,L)*(1.+D608*Q(I,J,L)))
-
- end do
- end do
- end do
- write(0,*)' after OMGA'
-
-
- THL=210.
- PLQ=70000.
-
- CALL TABLE(PTBL,TTBL,PT, &
- RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0)
-
- CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q)
- write(0,*)' after TABLEQ'
-
-
-!
-!
- IF(ME==0)THEN
- WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: '
- WRITE(6,51) (SPL(L),L=1,LSM)
- 50 FORMAT(14(F4.1,1X))
- 51 FORMAT(8(F8.1,1X))
- ENDIF
-!
-! COMPUTE DERIVED TIME STEPPING CONSTANTS.
-!
-!MEB need to get DT
-! DT = 120. !MEB need to get DT
-! NPHS = 4 !MEB need to get physics DT
- DTQ2 = DT * NPHS !MEB need to get physics DT
- TSPH = 3600./DT !MEB need to get DT
-
- IF (PTHRESH>0.) THEN
- PTHRESH=0.01*DTQ2/3.6E6 !-- Precip rate >= 0.01 mm/h
-! PTHRESH=0.01*DTQ2/(3600.*39.37) !-- Precip rate >= 0.01 inches/h
- ENDIF
-
- TSRFC=float(NSRFC)/TSPH
- IF(NSRFC==0)TSRFC=float(ifhr) !in case buket does not get emptied
- TRDLW=float(NRDLW)/TSPH
- IF(NRDLW==0)TRDLW=float(ifhr) !in case buket does not get emptied
- TRDSW=float(NRDSW)/TSPH
- IF(NRDSW==0)TRDSW=float(ifhr) !in case buket does not get emptied
- THEAT=float(NHEAT)/TSPH
- IF(NHEAT==0)THEAT=float(ifhr) !in case buket does not get emptied
- TCLOD=float(NCLOD)/TSPH
- IF(NCLOD==0)TCLOD=float(ifhr) !in case buket does not get emptied
- TPREC=float(NPREC)/TSPH
- IF(NPREC==0)TPREC=float(ifhr) !in case buket does not get emptied
-! TPREC=float(ifhr)
- print*,'TSRFC TRDLW TRDSW THEAT TCLOD TPREC= ' &
- ,TSRFC, TRDLW, TRDSW, THEAT, TCLOD, TPREC
-!MEB need to get DT
-
-!how am i going to get this information?
-! NPREC = INT(TPREC *TSPH+D50)
-! NHEAT = INT(THEAT *TSPH+D50)
-! NCLOD = INT(TCLOD *TSPH+D50)
-! NRDSW = INT(TRDSW *TSPH+D50)
-! NRDLW = INT(TRDLW *TSPH+D50)
-! NSRFC = INT(TSRFC *TSPH+D50)
-!how am i going to get this information?
-!
-! IF(ME==0)THEN
-! WRITE(6,*)' '
-! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS'
-! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC
-! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW
-! ENDIF
-!
-! COMPUTE DERIVED MAP OUTPUT CONSTANTS.
- DO L = 1,LSM
- ALSL(L) = ALOG(SPL(L))
- END DO
- write(0,*)' after ALSL'
-!
-!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN
- if(me==0)then
- print*,'writing out igds'
- igdout=110
-! open(igdout,file='griddef.out',form='unformatted'
-! + ,status='unknown')
- IF(MAPTYPE==203)THEN !A STAGGERED E-GRID
- WRITE(igdout)203
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)136
- WRITE(igdout)CENLAT
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)64
- WRITE(igdout)0
- WRITE(igdout)0
- WRITE(igdout)0
- WRITE(igdout)LATLAST
- WRITE(igdout)LONLAST
- ELSE IF(MAPTYPE==205)THEN !A STAGGERED B-GRID
- WRITE(igdout)205
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)136
- WRITE(igdout)CENLAT
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)64
- WRITE(igdout)LATLAST
- WRITE(igdout)LONLAST
- WRITE(igdout)0
- WRITE(igdout)0
- WRITE(igdout)0
- END IF
- open(111,file='copygb_gridnav.txt',form='formatted' &
- ,status='unknown')
- IF(MAPTYPE==203)THEN !A STAGGERED E-GRID
- write(111,1000) 2*IM-1,JM,LATSTART,LONSTART,CENLON, &
- NINT(dxval*107.),NINT(dyval*110.),CENLAT,CENLAT
- ELSE IF(MAPTYPE==205)THEN !A STAGGERED B-GRID
- if(grib=="grib2") then
- write(111,1000) IM,JM,LATSTART/1000,LONSTART/1000,CENLON/1000, &
- NINT(dxval*107.)/1000,NINT(dyval*110.)/1000, &
- CENLAT/1000,CENLAT/1000, &
- LATLAST/1000,LONLAST/1000
- endif
- END IF
-1000 format('255 3 ',2(I4,x),I6,x,I7,x,'8 ',I7,x,2(I6,x),'0 64', &
- 3(x,I6),x,I7)
- close(111)
-!
- IF (MAPTYPE==205)THEN !A STAGGERED B-GRID
- open(112,file='latlons_corners.txt',form='formatted' &
- ,status='unknown')
- if(grib=="grib2") then
- write(112,1001)LATSTART/1000,(LONSTART/1000)-360000, &
- LATSE/1000, &
- LONSE/1000,LATNW/1000,LONNW/1000,LATLAST/1000, &
- (LONLAST/1000)-360000
- endif
-1001 format(4(I6,x,I7,x))
- close(112)
- ENDIF
-
- end if
-
-! close all files
- call nemsio_close(nfile,iret=status)
- call nemsio_finalize()
-!
- write(0,*)'end of INIT_NEMS'
-
- RETURN
- END
diff --git a/sorc/ncep_post.fd/INITPOST_NETCDF.f b/sorc/ncep_post.fd/INITPOST_NETCDF.f
index 4476acf5b..17d79845b 100644
--- a/sorc/ncep_post.fd/INITPOST_NETCDF.f
+++ b/sorc/ncep_post.fd/INITPOST_NETCDF.f
@@ -1,39 +1,27 @@
!> @file
-! . . .
-!> SUBPROGRAM: INITPOST_NETCDF INITIALIZE POST FOR RUN
-!! PRGRMMR: Hui-Ya Chuang DATE: 2016-03-04
-!!
-!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND
-!! VARIABLES AT THE START OF GFS MODEL OR POST
-!! PROCESSOR RUN.
-!!
-!! REVISION HISTORY
-!! 2017-08-11 H Chuang start from INITPOST_GFS_NEMS_MPIIO.f
-!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend)
-!!
-!! USAGE: CALL INITPOST_NETCDF
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! NONE
-!! LIBRARY:
-!! COMMON - CTLBLK
-!! LOOKUP
-!! SOILDEPTH
-!!
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
+!> @brief initpost_netcdf() initializes post for run.
+!>
+!> @author Hui-Ya Chuang @date 2016-03-04
+
+!> This routine initializes constants and
+!> variables at the start of GFS model or post
+!> processor run.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2007-03-01 | Hui-Ya Chuang | Initial. Start from INITPOST_GFS_NEMS_MPIIO.f
+!> 2021-03-11 | Bo Cui | Change local arrays to dimension (im,jsta:jend)
+!> 2021-10-26 | Jesse Meng | 2D DECOMPOSITION
+!> 2022-02-07 | Wen Meng | Changes for parallel netcdf read
+!> 2022-03-15 | Wen Meng | Unify regional and global interfaces
+!> 2022-03-22 | Wen Meng | Read PWAT from model
+!> 2022-04-08 | Bo Cui | 2D decomposition for unified fv3 read interfaces
+!> 2022-06-05 | Hui-Ya Chuang | Modify dx/dy computation for RRFS domain over north pole
+!> 2022-07-10 | Wen Meng | Output lat/lon on four coner points of rotated lat-lon grids in text file.
+!> 2022-07-18 | Wen Meng | Read instant top of atmos ULWRF from model
+!>
+!> @author Hui-Ya Chuang @date 2016-03-04
SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
@@ -49,7 +37,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, &
cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, &
- tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, radot, sigt4, &
+ tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, landfrac, radot, sigt4, &
cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, &
islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, &
bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, &
@@ -57,15 +45,17 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
snopcx, sfcux, sfcvx, sfcuxi, sfcvxi, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, &
smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, &
uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, &
- ptoph, pboth, pblcfr, ttoph, runoff, maxtshltr, mintshltr, maxrhshltr, &
+ ptoph, pboth, pblcfr, ttoph, runoff, tecan, tetran, tedir, twa, maxtshltr, &
+ mintshltr, maxrhshltr, fdnsst, &
minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, &
cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa,rel_vort_maxhy1, &
maxqshltr, minqshltr, acond, sr, u10h, v10h,refd_max, w_up_max, w_dn_max, &
up_heli_max,up_heli_min,up_heli_max03,up_heli_min03,rel_vort_max01,u10max, v10max, &
- avgedir,avgecan,avgetrans,avgesnow,avgprec_cont,avgcprate_cont,rel_vort_max, &
+ avgedir,avgecan,paha,pahi,avgetrans,avgesnow,avgprec_cont,avgcprate_cont,rel_vort_max, &
avisbeamswin,avisdiffswin,airbeamswin,airdiffswin,refdm10c_max,wspd10max, &
alwoutc,alwtoac,aswoutc,aswtoac,alwinc,aswinc,avgpotevp,snoavg, &
- ti,aod550,du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550,prate_max
+ ti,aod550,du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550,prate_max, &
+ pwat
use soil, only: sldpth, sllevel, sh2o, smc, stc
use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice
use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, &
@@ -79,10 +69,12 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, &
jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, &
nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER, &
- iSF_SURFACE_PHYSICS,rdaod, aqfcmaq_on, modelname, smflag
+ iSF_SURFACE_PHYSICS,rdaod, aqfcmaq_on, modelname, smflag, &
+ ista, iend, ista_2l, iend_2u,iend_m
use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, &
dxval, dyval, truelat2, truelat1, psmapf, cenlat,lonstartv, lonlastv, cenlonv, &
- latstartv, latlastv, cenlatv,latstart_r,latlast_r,lonstart_r,lonlast_r, STANDLON
+ latstartv, latlastv,cenlatv,latstart_r,latlast_r,lonstart_r,lonlast_r, STANDLON, &
+ latse,lonse,latnw,lonnw
use upp_physics, only: fpvsnew
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
@@ -115,7 +107,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
character(len=20) :: VarName, VcoordName
integer :: Status, fldsize, fldst, recn, recn_vvel
character startdate*19,SysDepInfo*80,cgar*1
- character startdate2(19)*4
+ character startdate2(19)*4, flatlon*40
logical :: read_lonlat=.true.
!
! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK
@@ -159,15 +151,14 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
real, allocatable :: wrk1(:,:), wrk2(:,:)
real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), &
qs2d(:,:), cw2d(:,:), cfr2d(:,:)
- real(kind=4),allocatable :: vcoord4(:,:,:)
real, dimension(lm+1) :: ak5, bk5
real*8, allocatable :: pm2d(:,:), pi2d(:,:)
real, allocatable :: tmp(:)
- real :: buf(im,jsta_2l:jend_2u)
- real :: buf3d(im,jsta_2l:jend_2u,lm)
+ real :: buf(ista_2l:iend_2u,jsta_2l:jend_2u)
+ real :: buf3d(ista_2l:iend_2u,jsta_2l:jend_2u,lm)
-! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) &
-! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u)
+! real buf(ista_2l:iend_2u,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) &
+! ,buf3d(ista_2l:iend_2u,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u)
real LAT
integer isa, jsa, latghf, jtem, idvc, idsl, nvcoord, ip1, nn, npass
@@ -234,137 +225,137 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
if (aqfcmaq_on) then
- allocate(aacd(im,jsta_2l:jend_2u,lm))
- allocate(aalj(im,jsta_2l:jend_2u,lm))
- allocate(aalk1j(im,jsta_2l:jend_2u,lm))
- allocate(aalk2j(im,jsta_2l:jend_2u,lm))
+ allocate(aacd(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aalj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aalk1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aalk2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(abnz1j(im,jsta_2l:jend_2u,lm))
- allocate(abnz2j(im,jsta_2l:jend_2u,lm))
- allocate(abnz3j(im,jsta_2l:jend_2u,lm))
+ allocate(abnz1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(abnz2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(abnz3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(acaj(im,jsta_2l:jend_2u,lm))
- allocate(acet(im,jsta_2l:jend_2u,lm))
+ allocate(acaj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(acet(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(acli(im,jsta_2l:jend_2u,lm))
- allocate(aclj(im,jsta_2l:jend_2u,lm))
- allocate(aclk(im,jsta_2l:jend_2u,lm))
+ allocate(acli(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aclj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aclk(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(acors(im,jsta_2l:jend_2u,lm))
- allocate(acro_primary(im,jsta_2l:jend_2u,lm))
- allocate(acrolein(im,jsta_2l:jend_2u,lm))
- allocate(aeci(im,jsta_2l:jend_2u,lm))
- allocate(aecj(im,jsta_2l:jend_2u,lm))
- allocate(afej(im,jsta_2l:jend_2u,lm))
- allocate(aglyj(im,jsta_2l:jend_2u,lm))
+ allocate(acors(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(acro_primary(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(acrolein(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aeci(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aecj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(afej(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aglyj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(ah2oi(im,jsta_2l:jend_2u,lm))
- allocate(ah2oj(im,jsta_2l:jend_2u,lm))
- allocate(ah2ok(im,jsta_2l:jend_2u,lm))
+ allocate(ah2oi(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(ah2oj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(ah2ok(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(ah3opi(im,jsta_2l:jend_2u,lm))
- allocate(ah3opj(im,jsta_2l:jend_2u,lm))
- allocate(ah3opk(im,jsta_2l:jend_2u,lm))
+ allocate(ah3opi(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(ah3opj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(ah3opk(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(aiso1j(im,jsta_2l:jend_2u,lm))
- allocate(aiso2j(im,jsta_2l:jend_2u,lm))
- allocate(aiso3j(im,jsta_2l:jend_2u,lm))
+ allocate(aiso1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aiso2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aiso3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(aivpo1j(im,jsta_2l:jend_2u,lm))
- allocate(akj(im,jsta_2l:jend_2u,lm))
+ allocate(aivpo1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(akj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(ald2(im,jsta_2l:jend_2u,lm))
- allocate(ald2_primary(im,jsta_2l:jend_2u,lm))
+ allocate(ald2(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(ald2_primary(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(aldx(im,jsta_2l:jend_2u,lm))
+ allocate(aldx(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(alvoo1i(im,jsta_2l:jend_2u,lm))
- allocate(alvoo1j(im,jsta_2l:jend_2u,lm))
- allocate(alvoo2i(im,jsta_2l:jend_2u,lm))
- allocate(alvoo2j(im,jsta_2l:jend_2u,lm))
- allocate(alvpo1i(im,jsta_2l:jend_2u,lm))
- allocate(alvpo1j(im,jsta_2l:jend_2u,lm))
+ allocate(alvoo1i(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(alvoo1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(alvoo2i(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(alvoo2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(alvpo1i(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(alvpo1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(amgj(im,jsta_2l:jend_2u,lm))
- allocate(amnj(im,jsta_2l:jend_2u,lm))
+ allocate(amgj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(amnj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(anai(im,jsta_2l:jend_2u,lm))
- allocate(anaj(im,jsta_2l:jend_2u,lm))
- allocate(anak(im,jsta_2l:jend_2u,lm))
+ allocate(anai(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(anaj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(anak(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(anh4i(im,jsta_2l:jend_2u,lm))
- allocate(anh4j(im,jsta_2l:jend_2u,lm))
- allocate(anh4k(im,jsta_2l:jend_2u,lm))
+ allocate(anh4i(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(anh4j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(anh4k(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(ano3i(im,jsta_2l:jend_2u,lm))
- allocate(ano3j(im,jsta_2l:jend_2u,lm))
- allocate(ano3k(im,jsta_2l:jend_2u,lm))
+ allocate(ano3i(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(ano3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(ano3k(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(aolgaj(im,jsta_2l:jend_2u,lm))
- allocate(aolgbj(im,jsta_2l:jend_2u,lm))
+ allocate(aolgaj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aolgbj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(aomi(im,jsta_2l:jend_2u,lm))
- allocate(aomj(im,jsta_2l:jend_2u,lm))
+ allocate(aomi(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aomj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(aorgcj(im,jsta_2l:jend_2u,lm))
+ allocate(aorgcj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(aothri(im,jsta_2l:jend_2u,lm))
- allocate(aothrj(im,jsta_2l:jend_2u,lm))
+ allocate(aothri(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aothrj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(apah1j(im,jsta_2l:jend_2u,lm))
- allocate(apah2j(im,jsta_2l:jend_2u,lm))
- allocate(apah3j(im,jsta_2l:jend_2u,lm))
+ allocate(apah1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(apah2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(apah3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(apcsoj(im,jsta_2l:jend_2u,lm))
+ allocate(apcsoj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(apomi(im,jsta_2l:jend_2u,lm))
- allocate(apomj(im,jsta_2l:jend_2u,lm))
+ allocate(apomi(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(apomj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(aseacat(im,jsta_2l:jend_2u,lm))
- allocate(asij(im,jsta_2l:jend_2u,lm))
+ allocate(aseacat(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(asij(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(aso4i(im,jsta_2l:jend_2u,lm))
- allocate(aso4j(im,jsta_2l:jend_2u,lm))
- allocate(aso4k(im,jsta_2l:jend_2u,lm))
- allocate(asoil(im,jsta_2l:jend_2u,lm))
+ allocate(aso4i(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aso4j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(aso4k(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(asoil(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(asomi(im,jsta_2l:jend_2u,lm))
- allocate(asomj(im,jsta_2l:jend_2u,lm))
+ allocate(asomi(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(asomj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(asqtj(im,jsta_2l:jend_2u,lm))
+ allocate(asqtj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(asvoo1i(im,jsta_2l:jend_2u,lm))
- allocate(asvoo1j(im,jsta_2l:jend_2u,lm))
- allocate(asvoo2i(im,jsta_2l:jend_2u,lm))
- allocate(asvoo2j(im,jsta_2l:jend_2u,lm))
- allocate(asvoo3j(im,jsta_2l:jend_2u,lm))
+ allocate(asvoo1i(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(asvoo1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(asvoo2i(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(asvoo2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(asvoo3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(asvpo1i(im,jsta_2l:jend_2u,lm))
- allocate(asvpo1j(im,jsta_2l:jend_2u,lm))
- allocate(asvpo2i(im,jsta_2l:jend_2u,lm))
- allocate(asvpo2j(im,jsta_2l:jend_2u,lm))
- allocate(asvpo3j(im,jsta_2l:jend_2u,lm))
+ allocate(asvpo1i(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(asvpo1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(asvpo2i(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(asvpo2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(asvpo3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(atij(im,jsta_2l:jend_2u,lm))
+ allocate(atij(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(atol1j(im,jsta_2l:jend_2u,lm))
- allocate(atol2j(im,jsta_2l:jend_2u,lm))
- allocate(atol3j(im,jsta_2l:jend_2u,lm))
+ allocate(atol1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(atol2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(atol3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(atoti(im,jsta_2l:jend_2u,lm))
- allocate(atotj(im,jsta_2l:jend_2u,lm))
- allocate(atotk(im,jsta_2l:jend_2u,lm))
+ allocate(atoti(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(atotj(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(atotk(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(atrp1j(im,jsta_2l:jend_2u,lm))
- allocate(atrp2j(im,jsta_2l:jend_2u,lm))
+ allocate(atrp1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(atrp2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(axyl1j(im,jsta_2l:jend_2u,lm))
- allocate(axyl2j(im,jsta_2l:jend_2u,lm))
- allocate(axyl3j(im,jsta_2l:jend_2u,lm))
+ allocate(axyl1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(axyl2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(axyl3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
- allocate(pm25ac(im,jsta_2l:jend_2u,lm))
- allocate(pm25at(im,jsta_2l:jend_2u,lm))
- allocate(pm25co(im,jsta_2l:jend_2u,lm))
+ allocate(pm25ac(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(pm25at(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(pm25co(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
endif
@@ -374,14 +365,17 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
WRITE(6,*)'INITPOST: ENTER INITPOST_NETCDF'
WRITE(6,*)'me=',me, &
'jsta_2l=',jsta_2l,'jend_2u=', &
- jend_2u,'im=',im
+ jend_2u,'im=',im, &
+ 'ista_2l=',ista_2l,'iend_2u=',iend_2u, &
+ 'ista=',ista,'iend=',iend, &
+ 'iend_m=',iend_m
!
- isa = im / 2
+ isa = (ista+iend) / 2
jsa = (jsta+jend) / 2
!$omp parallel do private(i,j)
do j = jsta_2l, jend_2u
- do i=1,im
+ do i= ista_2l, iend_2u
buf(i,j) = spval
enddo
enddo
@@ -477,8 +471,8 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
dyval=dum_const*gdsdegr
end if
- print*,'lonstart,latstart,cenlon,cenlat,dyval,dxval', &
- lonstart,latstart,cenlon,cenlat,dyval,dxval
+! print*,'lonstart,latstart,cenlon,cenlat,dyval,dxval', &
+! lonstart,latstart,cenlon,cenlat,dyval,dxval
! Jili Dong add support for regular lat lon (2019/03/22) start
else if(trim(varcharval)=='latlon')then
@@ -616,9 +610,13 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
end if
STANDLON = cenlon
- print*,'lonstart,latstart,cenlon,cenlat,truelat1,truelat2,stadlon,dyval,dxval', &
+ print*,'lonstart,latstart,cenlon,cenlat,truelat1,truelat2, &
+ stadlon,dyval,dxval', &
lonstart,latstart,cenlon,cenlat,truelat1,truelat2,standlon,dyval,dxval
+ else if(trim(varcharval)=='gaussian')then
+ MAPTYPE=4
+ idrt=4
else ! setting default maptype
MAPTYPE=0
idrt=0
@@ -635,7 +633,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
!$omp parallel do private(i,j)
do j = jsta_2l, jend_2u
- do i = 1, im
+ do i = ista_2l, iend_2u
LMV(i,j) = lm
LMH(i,j) = lm
end do
@@ -646,7 +644,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
!$omp parallel do private(i,j,l)
do l = 1, lm
do j = jsta_2l, jend_2u
- do i = 1, im
+ do i = ista_2l, iend_2u
HTM (i,j,l) = 1.0
VTM (i,j,l) = 1.0
end do
@@ -676,7 +674,6 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
! write(0,*)'nrec=',nrec
!allocate(recname(nrec),reclevtyp(nrec),reclev(nrec))
allocate(glat1d(jm),glon1d(im))
- allocate(vcoord4(lm+1,3,2))
! hardwire idate for now
! idate=(/2017,08,07,00,0,0,0,0/)
@@ -711,7 +708,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
! Jili Dong check output format for coordinate reading
Status=nf90_inq_varid(ncid3d,'grid_xt',varid)
Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims)
- if(numDims==1) then
+ if(numDims==1.and.modelname=="FV3R") then
read_lonlat=.true.
else
read_lonlat=.false.
@@ -732,7 +729,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
if(numDims==1)then
Status=nf90_get_var(ncid3d,varid,glon1d)
do j=jsta,jend
- do i=1,im
+ do i=ista,iend
gdlon(i,j) = real(glon1d(i),kind=4)
end do
end do
@@ -755,13 +752,13 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
if(maxval(abs(dummy))<2.0*pi)convert_rad_to_deg=.true.
if(convert_rad_to_deg)then
do j=jsta,jend
- do i=1,im
+ do i=ista,iend
gdlon(i,j) = real(dummy(i,j),kind=4)*180./pi
end do
end do
else
do j=jsta,jend
- do i=1,im
+ do i=ista,iend
gdlon(i,j) = real(dummy(i,j),kind=4)
end do
end do
@@ -769,9 +766,13 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
if(convert_rad_to_deg)then
lonstart = nint(dummy(1,1)*gdsdegr)*180./pi
lonlast = nint(dummy(im,jm)*gdsdegr)*180./pi
+ lonse = nint(dummy(im,1)*gdsdegr)*180./pi
+ lonnw = nint(dummy(1,jm)*gdsdegr)*180./pi
else
lonstart = nint(dummy(1,1)*gdsdegr)
lonlast = nint(dummy(im,jm)*gdsdegr)
+ lonse = nint(dummy(im,1)*gdsdegr)
+ lonnw = nint(dummy(1,jm)*gdsdegr)
end if
! Jili Dong add support for regular lat lon (2019/03/22) start
@@ -801,7 +802,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
if(numDims==1)then
Status=nf90_get_var(ncid3d,varid,glat1d)
do j=jsta,jend
- do i=1,im
+ do i=ista,iend
gdlat(i,j) = real(glat1d(j),kind=4)
end do
end do
@@ -812,13 +813,13 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
if(maxval(abs(dummy))1.0E6 .or. pint(1,jsta_2l,lp1)<50000.) &
+ do i=ista,iend
+! if(pint(i,j,lp1)>1.0E6 .or. pint(ista_2l,jsta_2l,lp1)<50000.) &
! print*,'bad psfc ',i,j,pint(i,j,lp1)
end do
end do
@@ -1677,14 +1596,14 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d)
pt = ak5(1)
do j=jsta,jend
- do i=1,im
+ do i=ista,iend
pint(i,j,1)= pt
end do
end do
do l=2,lp1
do j=jsta,jend
- do i=1,im
+ do i=ista,iend
if (dpres(i,j,l-1) @file
-!
-!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN
-!! PRGRMMR: RUSS TREADON ORG: W/NP2 DATE: 93-11-10
-!!
-!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND
-!! VARIABLES AT THE START OF AN ETA MODEL OR POST
-!! PROCESSOR RUN.
-!!
-!! THIS ROUTINE ASSUMES THAT INTEGERS AND REALS ARE THE SAME SIZE
-!!
-!! PROGRAM HISTORY LOG:
-!! 93-11-10 RUSS TREADON - ADDED DOCBLOC
-!! 98-05-29 BLACK - CONVERSION OF POST CODE FROM 1-D TO 2-D
-!! 99-01 20 TUCCILLO - MPI VERSION
-!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT
-!! 02-06-19 MIKE BALDWIN - WRF VERSION
-!! 02-08-15 H CHUANG - UNIT CORRECTION AND GENERALIZE PROJECTION OPTIONS
-!! 03-07-25 H CHUANG - MODIFIED TO PROCESS NMM WRF
-!! 05-12-05 H CHUANG - ADD CAPABILITY TO OUTPUT OFF-HOUR FORECAST WHICH HAS
-!! NO INPACTS ON ON-HOUR FORECAST
-!! 21-03-11 Bo Cui - change local arrays to dimension (im,jsta:jend)
-!!
-!! USAGE: CALL INIT
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! NONE
-!! LIBRARY:
-!! COMMON - CTLBLK
-!! LOOKUP
-!! SOILDEPTH
-!!
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
- SUBROUTINE INITPOST_NMM
-
- use vrbls3d, only: t, u, uh, v, vh, q, cwm, f_ice, f_rain, f_rimef, q,&
- qqw, qqr, qqs, qqi, qqg, qqw, cwm , q2, wh, pint, alpint, pmid,&
- omga, pmidv, zmid, rlwtt, rswtt, ttnd, tcucn, train, exch_h,&
- el_pbl, cfr, zint, REF_10CM, qqni, qqnr, qrimef
- use vrbls2d, only: fis, cfrach, cfracl, cfracm, u10h, u10, v10h, v10,th10,&
- q10, tshltr, qshltr, pshltr, smstav, smstot, acfrcv, acfrst, ncfrcv,&
- ncfrst, ssroff, bgroff, sfcevp, sfcexc, vegfrc, acsnow, acsnom,&
- cmc, sst, mdltaux, mdltauy, thz0, qz0, uz0, vz0, qs, z0, pblh, mixht,&
- ustar, akhs, akms, ths, prec, cuprec, acprec, ancprc, cprate, cuppt,&
- lspa, cldefi, htop, hbot, htopd, czmean, rswout, rlwin, rlwtoa, sigt4,&
- radot, aswin, aswout, alwin, alwout, alwtoa, aswtoa, hbotd, htops,&
- hbots, sr, rswin, rswinc, czen, tg, soiltb, twbs, sfcshx, qwbs,&
- sfclhx, grnflx, subshx, potevp, sno, si, pctsno, ivgtyp, isltyp,&
- islope, albedo, albase, mxsnal, epsr, f, REFC_10CM, REFD_MAX, &
- RSWTOA, SWUPT, ACSWUPT, SWDNT, ACSWDNT, CD10, CH10
- use soil, only: smc, sh2o, stc, sldpth, sllevel
- use masks, only: lmv, lmh, htm, vtm, hbm2, sm, sice, gdlat, gdlon, dx, dy
- use params_mod, only: tfrz, g, rd, d608, rtd, dtr, erad
- use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl,&
- qs0, sqs, sthe, the0, ttblq, rdpq, rdtheq, stheq, the0q
- use ctlblk_mod, only: jsta, jend, nprec, jsta_2l, jend_2u, filename,&
- datahandle, datestr, ihrst, imin, sdat, spval, imp_physics, pt,&
- icu_physics, pdtop, nsoil, isf_surface_physics, jsta_m, jend_m,&
- avrain, avcnvc, ardsw, ardlw, asrfc, me, mpi_comm_comp, nphs, spl,&
- lsm, dt, dtq2,tsrfc, trdlw, trdsw, idat, ifhr, ifmin, restrt,&
- theat, tclod, tprec, alsl, lm, im, jm , submodelname
- use gridspec_mod, only: latstart, latlast, cenlat, lonstart, lonlast,&
- cenlon, dxval, dyval, maptype, gridtype, truelat1, truelat2,&
- psmapf
-! use wrf_io_flags_mod
-!
- implicit none
-!
-! INCLUDE/SET PARAMETERS.
-!
- INCLUDE "mpif.h"
-!
-! This version of INITPOST shows how to initialize, open, read from, and
-! close a NetCDF dataset. In order to change it to read an internal (binary)
-! dataset, do a global replacement of _ncd_ with _int_.
- real :: dcenlat, dcenlon
- character(len=31) :: VarName
- integer :: Status, cen1, cen2
- character startdate*19,SysDepInfo*80
-!
-! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK
-! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE.
-!
-! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE
-! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE.
- CHARACTER*4 RESTHR
- INTEGER IDATE(8),JDATE(8)
- INTEGER :: i_parent_start, j_parent_start
-!
-! DECLARE VARIABLES.
-!
- REAL RINC(5)
- REAL ETA1(LM), ETA2(LM)
- REAL DUMMY ( IM, JM )
-! REAL DUMMY2 ( IM, JM )
- real, allocatable :: fi(:,:,:)
- REAL DUM3D ( IM+1, JM+1, LM+1 )
- REAL DUM3D2 ( IM+1, JM+1, LM+1 )
-!mp
- INTEGER IDUMMY ( IM, JM )
-!
-!jw
- integer ii,jj,js,je,jev,iyear,imn,iday,itmp,ioutcount,istatus, &
- nsrfc,nrdlw,nrdsw,nheat,nclod, &
- I,J,L,LL,N,LONEND,LATEND,IMM,INAV,IRTN, &
- IFDX,IFDY,IGDOUT,ICEN,JCEN
-! integer iw, ie
- real TSPH,fact,dumcst,tstart,tmp
- real LAT
-!
-! Declarations for :
-! putting 10 m wind on V points because copygb assume such
- INTEGER IE, IW
-!code from R.Rozumalski
- INTEGER latnm, latsm, lonem, lonwm, idxave, dlat, dlon, nlat, nlon
-
-!***********************************************************************
-! START INIT HERE.
-!
- WRITE(6,*)'INITPOST: ENTER INITPOST'
- print*,'im,jm,lm= ',im,jm,lm
-
- ii=im/2 ! diagnostic print indices
- jj=(jsta+jend)/2
- ll=lm/2
-!
-! STEP 1. READ MODEL OUTPUT FILE
-!
-!
-!***
-!
-! set default to not empty buket
- NSRFC=0
- NRDLW=0
- NRDSW=0
- NHEAT=0
- NCLOD=0
- NPREC=0
-
-! LMH always = LM for sigma-type vert coord
-! LMV always = LM for sigma-type vert coord
-
- do j = jsta_2l, jend_2u
- do i = 1, im
- LMV ( i, j ) = lm
- LMH ( i, j ) = lm
- end do
- end do
-
-
-! HTM VTM all 1 for sigma-type vert coord
-
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- HTM ( i, j, l ) = 1.0
- VTM ( i, j, l ) = 1.0
- end do
- end do
- end do
-!
-! how do I get the filename?
-! fileName = '/ptmp/wx20mb/wrfout_01_030500'
-! DateStr = '2002-03-05_18:00:00'
-! how do I get the filename?
- call ext_ncd_ioinit(SysDepInfo,Status)
- print*,'called ioinit', Status
- call ext_ncd_open_for_read( trim(fileName), 0, 0, " ", &
- DataHandle, Status)
- print*,'called open for read', Status
- if ( Status /= 0 ) then
- print*,'error opening ',fileName, ' Status = ', Status ; stop
- endif
-! get date/time info
-! this routine will get the next time from the file, not using it
- print *,'DateStr before calling ext_ncd_get_next_time=',DateStr
-! call ext_ncd_get_next_time(DataHandle, DateStr, Status)
- print *,'DateStri,Status,DataHandle = ',DateStr,Status,DataHandle
-
-! The end j row is going to be jend_2u for all variables except for V.
- JS=JSTA_2L
- JE=JEND_2U
- IF (JEND_2U==JM) THEN
- JEV=JEND_2U+1
- ELSE
- JEV=JEND_2U
- ENDIF
-!
-! Getting start time
- call ext_ncd_get_dom_ti_char(DataHandle,'START_DATE',startdate, &
- status )
-! patch for NMM WRF because it does not have start-date in output yet
-! startdate='2003-04-17T00:00:00'
- print*,'startdate= ',startdate
-!
- jdate=0
- idate=0
- read(startdate,15)iyear,imn,iday,ihrst,imin
- 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2)
- print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin
- print*,'processing yr mo day hr min=',idat(3),idat(1),idat(2), &
- idat(4),idat(5)
- idate(1)=iyear
- idate(2)=imn
- idate(3)=iday
- idate(5)=ihrst
- idate(6)=imin
- SDAT(1)=imn
- SDAT(2)=iday
- SDAT(3)=iyear
-!
- jdate(1)=idat(3)
- jdate(2)=idat(1)
- jdate(3)=idat(2)
- jdate(5)=idat(4)
- jdate(6)=idat(5)
-! CALL W3DIFDAT(JDATE,IDATE,2,RINC)
-! ifhr=nint(rinc(2))
- CALL W3DIFDAT(JDATE,IDATE,0,RINC)
- ifhr=nint(rinc(2)+rinc(1)*24.)
- ifmin=nint(rinc(3))
- print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,fileName
-
-! Getting tstart
- call ext_ncd_get_dom_ti_real(DataHandle,'TSTART',tmp,1,ioutcount, &
- istatus)
- if(istatus==0)then
- tstart=tmp
- else
- tstart=0.
- end if
- print*,'status for getting TSTART= ',istatus
- print*,'TSTART= ',TSTART
-
-! Getting restart
-
- RESTRT=.TRUE. ! set RESTRT default
- call ext_ncd_get_dom_ti_integer(DataHandle,'RESTARTBIN',itmp,1, &
- ioutcount,istatus)
-
- IF(itmp < 1)THEN
- RESTRT=.FALSE.
- ELSE
- RESTRT=.TRUE.
- END IF
-
- print*,'status for getting RESTARTBIN= ',istatus
- print*,'Is this a restrt run? ',RESTRT
-
-! IF(RESTRT)THEN
-! ifhr=ifhr+NINT(tstart)
-! print*,'new forecast hours for restrt run= ',ifhr
-! END IF
-
- IF(tstart > 1.0E-2)THEN
- ifhr=ifhr+NINT(tstart)
- rinc=0
- idate=0
- rinc(2)=-1.0*ifhr
- call w3movdat(rinc,jdate,idate)
- SDAT(1)=idate(2)
- SDAT(2)=idate(3)
- SDAT(3)=idate(1)
- IHRST=idate(5)
- print*,'new forecast hours for restrt run= ',ifhr
- print*,'new start yr mo day hr min =',sdat(3),sdat(1), &
- sdat(2),ihrst,imin
- END IF
-
- VarName='HBM2'
- HBM2=SPVAL
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- HBM2 ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! OK, since all of the variables are dimensioned/allocated to be
-! the same size, this means we have to be careful int getVariable
-! to not try to get too much data. For example,
-! DUM3D is dimensioned IM+1,JM+1,LM+1 but there might actually
-! only be im,jm,lm points of data available for a particular variable.
-
-! get 3-D variables
- VarName='T'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- t ( i, j, l ) = dum3d ( i, j, l )
-! if(l==1)print*,'Debug: I,J,T= ',i,j,t ( i, j, l )
-! t ( i, j, l ) = dum3d ( i, j, l ) + 300.
-! th ( i, j, l ) = dum3d ( i, j, l ) + 300.
- end do
- end do
- end do
- do l=1,lm
- if(jj>= jsta .and. jj<=jend)print*,'sample L,T= ',L,T(ii,jj,l)
- end do
-
-! VarName='T_ADJ'
-! call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D,
-! & IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
-! do l = 1, lm
-! do j = jsta_2l, jend_2u
-! do i = 1, im
-! t_ADJ ( i, j, l ) = dum3d ( i, j, l )
-! end do
-! end do
-! end do
-! do l=1,lm
-! if(jj>= jsta .and. jj<=jend)print*,'sample L,T_ADJ= ',L
-! &,T_ADJ(ii,jj,l)
-! end do
-
-
- VarName='U'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- u ( i, j, l ) = dum3d ( i, j, l )
- UH( i, j, l ) = dum3d ( i, j, l )
-! if(l==1)print*,'Debug: I,J,U= ',i,j,u( i, j, l )
- end do
- end do
-! fill up UH which is U at P-points including 2 row halo
-! do j = jsta_2l, jend_2u
-! do i = 1, im
-! UH (I,J,L) = (dum3d(I,J,L)+dum3d(I+1,J,L))*0.5
-! end do
-! end do
- end do
- if(jj>= jsta .and. jj<=jend)print*,'sample U= ',U(ii,jj,ll)
- VarName='V'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- v ( i, j, l ) = dum3d ( i, j, l )
- VH( i, j, l ) = dum3d ( i, j, l )
- end do
- end do
-! fill up VH which is V at P-points including 2 row halo
-! do j = jsta_2l, jend_2u
-! do i = 1, im
-! VH(I,J,L) = (dum3d(I,J,L)+dum3d(I,J+1,L))*0.5
-! end do
-! end do
- end do
- if(jj>= jsta .and. jj<=jend)print*,'sample V= ',V(ii,jj,ll)
-
- call ext_ncd_get_dom_ti_integer(DataHandle,'MP_PHYSICS' &
- ,itmp,1,ioutcount,istatus)
- imp_physics=itmp
-! Chuang: will initialize microphysics constants differently for 85 now
-! if(imp_physics == 85) imp_physics=5 !HWRF
- print*,'MP_PHYSICS= ',imp_physics
-
-! Initializes constants for Ferrier microphysics
- if(imp_physics==5 .or. imp_physics==15 .or. imp_physics==85 &
- .or. imp_physics==95)then
- CALL MICROINIT(imp_physics)
- end if
-
- call ext_ncd_get_dom_ti_integer(DataHandle,'CU_PHYSICS' &
- ,itmp,1,ioutcount,istatus)
- icu_physics=itmp
- if (icu_physics == 84 .or. icu_physics == 85) icu_physics = 4 ! HWRF
- print*,'CU_PHYSICS= ',icu_physics
-
- ! Set these values to SPVAL to insure they are initialized a
- ! fact that the code relies on later....
- qqw=spval
- qqr=spval
- qqs=spval
- qqi=spval
- qqg=spval
-
-!KRF: NMM and ARW direct read of radar ref for microphysic options
-! mp options: 2,4,6,7,8,10,14,16
-! REFL_10cm --> REF_10CM
-! REFD_MAX --> REFD_MAX
- VarName='REFL_10CM'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- REF_10CM ( i, j, l ) = dum3d ( i, j, l )
- end do
- end do
- end do
- do l=1,lm
- if(jj>= jsta .and. jj<=jend)print*,'sample L,T= ',L,T(ii,jj,l)
- end do
-
- VarName='REFD_MAX'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- REFD_MAX ( i, j ) = dummy ( i, j )
- end do
- end do
-! print*,'REFD_MAX at ',ii,jj,' = ',REFD_MAX(ii,jj)
-! END KRF
-
- if(imp_physics==5 .or. imp_physics==15 .or. imp_physics==85 .or. imp_physics==95)then
-
- VarName='Q'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- if (dum3d(i,j,l) < 10E-12) dum3d(i,j,l) = 10E-12
- q ( i, j, l ) = dum3d ( i, j, l )
- end do
- end do
- end do
- print*,'finish reading specific humidity'
- if(jj>= jsta .and. jj<=jend)print*,'sample Q= ',Q(ii,jj,ll)
-
- else
- VarName='QVAPOR'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
-! q ( i, j, l ) = dum3d ( i, j, l )
-! if(l==1)print*,'Debug: I,J,Q= ',i,j,q( i, j, l )
-!CHC CONVERT MIXING RATIO TO SPECIFIC HUMIDITY
- if (dum3d(i,j,l) < 10E-12) dum3d(i,j,l) = 10E-12
- q ( i, j, l ) = dum3d ( i, j, l )/(1.0+dum3d ( i, j, l ))
- end do
- end do
- end do
- print*,'finish reading specific humidity'
- if(jj>= jsta .and. jj<=jend)print*,'sample Q= ',Q(ii,jj,ll)
- endif
-
- if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then
- VarName='CWM' !?????
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- cwm ( i, j, l ) = dum3d ( i, j, l )
- end do
- end do
- end do
- print*,'finish reading cloud mixing ratio'
-
- VarName='F_ICE'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- F_ICE ( i, j, l ) = dum3d ( i, j, l )
- end do
- end do
- end do
-
- VarName='F_RAIN'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- F_RAIN ( i, j, l ) = dum3d ( i, j, l )
- end do
- end do
- end do
-
- VarName='F_RIMEF'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- F_RIMEF ( i, j, l ) = dum3d ( i, j, l )
- end do
- end do
- end do
-
- else ! retrieve hydrometeo fields directly for non-Ferrier
- cwm=spval !make sure set
- F_RimeF=spval !make sure set
-
- if(imp_physics/=0)then
- VarName='QCLOUD'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
-! partition cloud water and ice for WSM3
- if(imp_physics==3)then
- if(t(i,j,l) >= TFRZ)then
- qqw ( i, j, l ) = dum3d ( i, j, l )
- else
- qqi ( i, j, l ) = dum3d ( i, j, l )
- end if
- else ! bug fix provided by J CASE
- qqw ( i, j, l ) = dum3d ( i, j, l )
- end if
- cwm(i,j,l)=dum3d(i,j,l)
- end do
- end do
- end do
- end if
- if(jj>= jsta .and. jj<=jend)print*,'sample qqw= ' &
- ,Qqw(ii,jj,ll)
-
- if(imp_physics/=1 .and. imp_physics/=3 &
- .and. imp_physics/=0)then
- VarName='QICE'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- qqi ( i, j, l ) = dum3d ( i, j, l )
- cwm(i,j,l)=cwm(i,j,l)+dum3d(i,j,l)
- end do
- end do
- end do
- end if
- if(jj>= jsta .and. jj<=jend)print*,'sample qqi= ' &
- ,Qqi(ii,jj,ll)
-
- if(imp_physics==15) then
- VarName='QRIMEF'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- qrimef ( i, j, l ) = dum3d ( i, j, l )
- end do
- end do
- end do
- end if
- if(jj>= jsta .and. jj<=jend)print*,'sample qrimef= ' &
- ,Qrimef(ii,jj,ll)
-
- if(imp_physics/=0)then
- VarName='QRAIN'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
-! partition rain and snow for WSM3
- if(imp_physics == 3)then
- if(t(i,j,l) >= TFRZ)then
- qqr ( i, j, l ) = dum3d ( i, j, l )
- else
- qqs ( i, j, l ) = dum3d ( i, j, l )
- end if
- else ! bug fix provided by J CASE
- qqr ( i, j, l ) = dum3d ( i, j, l )
- end if
- cwm(i,j,l)=cwm(i,j,l)+dum3d(i,j,l)
- end do
- end do
- end do
- end if
- if(jj>= jsta .and. jj<=jend)print*,'sample qqr= ' &
- ,Qqr(ii,jj,ll)
-
- if(imp_physics/=1 .and. imp_physics/=3 &
- .and. imp_physics/=0)then
- VarName='QSNOW'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- qqs ( i, j, l ) = dum3d ( i, j, l )
- cwm(i,j,l)=cwm(i,j,l)+dum3d(i,j,l)
- end do
- end do
- end do
- end if
- if(jj>= jsta .and. jj<=jend)print*,'sample qqs= ' &
- ,Qqs(ii,jj,ll)
-
- if(imp_physics==2 .or. imp_physics==6 &
- .or. imp_physics==8 .or. imp_physics==28)then
- VarName='QGRAUP'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- qqg ( i, j, l ) = dum3d ( i, j, l )
- cwm(i,j,l)=cwm(i,j,l)+dum3d(i,j,l)
- end do
- end do
- end do
- end if
- if(jj>= jsta .and. jj<=jend)print*,'sample qqg= ' &
- ,Qqg(ii,jj,ll)
-
-! KRS: Add concentrations for HWRF output
- if(imp_physics==8 .or. imp_physics==9)then
- VarName='QNICE'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM, JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- qqni ( i, j, l ) = dum3d ( i, j, l )
- if(i==im/2.and.j==(jsta+jend)/2)print*,'sample QQNI= ', &
- i,j,l,QQNI ( i, j, l )
- end do
- end do
- end do
- VarName='QNRAIN'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM, JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- qqnr ( i, j, l ) = dum3d ( i, j, l )
- if(i==im/2.and.j==(jsta+jend)/2)print*,'sample QQNR= ', &
- i,j,l,QQNR ( i, j, l )
- end do
- end do
- end do
- end if
-! KRS: End add concentrations for HWRF
-
- end if ! end of retrieving hydrometeo for different MP options
-
-
-! call getVariable(fileName,DateStr,DataHandle,'TKE_PBL',DUM3D,
- call getVariable(fileName,DateStr,DataHandle,'Q2',DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- q2 ( i, j, l ) = dum3d ( i, j, l )
- end do
- end do
- end do
- VarName='W'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM+1)
-! & IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
-! do l = 1, lm+1
-! do j = jsta_2l, jend_2u
-! do i = 1, im
-! w ( i, j, l ) = dum3d ( i, j, l )
-! end do
-! end do
-! end do
-! fill up WH which is W at P-points including 2 row halo
- DO L=1,LM
- DO I=1,IM
- DO J=JSTA_2L,JEND_2U
-! WH(I,J,L) = (W(I,J,L)+W(I,J,L+1))*0.5
- wh ( i, j, l ) = dum3d ( i, j, l+1 )
- ENDDO
- ENDDO
- ENDDO
- print*,'finish reading W'
-
-!MEB call getVariable(fileName,DateStr,DataHandle,'QRAIN',new)
-
- VarName='PINT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM+1)
-! VarName='P'
-! call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D2,
-! & IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm+1
- do j = jsta_2l, jend_2u
- do i = 1, im
-! PMID(I,J,L)=DUM3D(I,J,L)+DUM3D2(I,J,L)
- PINT(I,J,L)=DUM3D(I,J,L)
- ALPINT(I,J,L)=ALOG(PINT(I,J,L))
- end do
- end do
- end do
-! do l = 1, lm+1
-! if(jj>= jsta .and. jj<=jend)print*,'sample PINT= '
-! & ,PINT(ii,jj,l)
-! end do
-!
- DO L=1,LM
- DO I=1,IM
- DO J=JSTA_2L,JEND_2U
- PMID(I,J,L)=(PINT(I,J,L)+PINT(I,J,L+1))*0.5
-! TH(I,J,L)=T(I,J,L)*(1.E5/PMID(I,J,L))**CAPA
- IF(ABS(T(I,J,L))>1.0E-3) &
- OMGA(I,J,L) = -WH(I,J,L)*PMID(I,J,L)*G/ &
- (RD*T(I,J,L)*(1.+D608*Q(I,J,L)))
-!
-! PINT(I,J,L)=EXP((ALOG(PMID(I,J,L-1))+
-! & ALOG(PMID(I,J,L)))*0.5) ! ave of ln p
-! ALPINT(I,J,L)=ALOG(PINT(I,J,L))
- ENDDO
- ENDDO
- ENDDO
-!
- do l = 1, lm
- do j = jsta, jend
- do i = 1, im-MOD(J,2)
- IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC
- PMIDV(I,J,L)=0.5*(PMID(I,J,L)+PMID(I+1,J,L))
- ELSE IF(J==JM .AND. I1.0e-5)print*,'nonzero ncfrcv',ncfrcv(i,j)
- end do
- end do
-
- VarName='NCFRST'
- write(6,*) 'call getIVariable for : ', VarName
- call getIVariableN(fileName,DateStr,DataHandle,VarName,IDUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ncfrst ( i, j ) = float(idummy ( i, j ))
-! if(ncfrst(i,j)>1.0e-5)print*,'nonzero ncfrst',ncfrst(i,j)
- end do
- end do
-
- VarName='SSROFF'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SSROFF ( i, j ) = dummy ( i, j )
- end do
- end do
- VarName='UDROFF'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- BGROFF ( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='SFCEVP'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SFCEVP( i, j ) = dummy ( i, j )
- end do
- end do
-! print*,'SFCEVP at ',ii,jj,' = ',SFCEVP(ii,jj)
-
- VarName='CD10'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY,&
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- CD10( i, j ) = dummy ( i, j )
- end do
- end do
-! print*,'CD10 at ',ii,jj,' = ',CD10(ii,jj)
-
- VarName='CH10'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY,&
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- CH10( i, j ) = dummy ( i, j )
- end do
- end do
-! print*,'CD10 at ',ii,jj,' = ',CD10(ii,jj)
-
- VarName='SFCEXC'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SFCEXC( i, j ) = dummy ( i, j )
- end do
- end do
-! print*,'SFCEXC at ',ii,jj,' = ',SFCEXC(ii,jj)
- VarName='VEGFRC'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- VEGFRC ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'VEGFRC at ',ii,jj,' = ',VEGFRC(ii,jj)
- VarName='ACSNOW'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ACSNOW ( i, j ) = dummy ( i, j )
- end do
- end do
- VarName='ACSNOM'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ACSNOM ( i, j ) = dummy ( i, j )
- end do
- end do
-! VarName='CANWAT'
- VarName='CMC'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- CMC ( i, j ) = dummy ( i, j )
- end do
- end do
- VarName='SST'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SST ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'SST at ',ii,jj,' = ',sst(ii,jj)
-
- VarName='TAUX'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- MDLTAUX ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'MDLTAUX at ',ii,jj,' = ',mdltaux(ii,jj)
-
- VarName='TAUY'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- MDLTAUY ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'MDLTAUY at ',ii,jj,' = ',mdltauy(ii,jj)
-
- VarName='EXCH_H'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- EXCH_H ( i, j, l ) = dum3d ( i, j, l )
- dummy(i,j)=dum3d ( i, j, l )
- end do
- end do
- print*,'l, max exch = ',l,maxval(dummy)
- end do
- do l=1,lm
- print*,'sample EXCH_H= ',EXCH_H(ii,jj,l)
- end do
-
- VarName='EL_PBL'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- EL_PBL ( i, j, l ) = dum3d ( i, j, l )
- dummy(i,j)=dum3d ( i, j, l )
- end do
- end do
- print*,'l, max EL_PBL = ',l,maxval(dummy)
- end do
-
-
- VarName='THZ0'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- THZ0 ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'THZ0 at ',ii,jj,' = ',THZ0(ii,jj)
- VarName='QZ0'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- QZ0 ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'QZ0 at ',ii,jj,' = ',QZ0(ii,jj)
- VarName='UZ0'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- UZ0 ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'UZ0 at ',ii,jj,' = ',UZ0(ii,jj)
- VarName='VZ0'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- VZ0 ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'VZ0 at ',ii,jj,' = ',VZ0(ii,jj)
-! VarName='QSFC'
- VarName='QS'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- QS ( i, j ) = dummy ( i, j )
-! if(qs(i,j)>1.0e-7)print*,'nonzero qsfc'
- end do
- end do
-
- VarName='Z0'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- Z0 ( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='PBLH'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- PBLH( i, j ) = dummy ( i, j )
- end do
- end do
-! write(6,*) 'PBLH(ii,jj): ', DUMMY(ii,jj)
-
- VarName='MIXHT' !PLee (3/07)
- MIXHT=SPVAL !Init value to detect read failure
- call getVariable(filename,DateStr,DataHandle,Varname,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- MIXHT( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='USTAR'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- USTAR( i, j ) = dummy ( i, j )
- end do
- end do
-
- print*,'USTAR at ',ii,jj,' = ',USTAR(ii,jj)
- VarName='AKHS_OUT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- AKHS ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'max akhs= ',maxval(akhs)
- VarName='AKMS_OUT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- AKMS ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'max akms= ',maxval(akms)
-
-!
-! In my version, variable is TSK (skin temp, not skin pot temp)
-!
-!mp call getVariable(fileName,DateStr,DataHandle,'THSK',DUMMY,
-! VarName='TSK'
- VarName='THS'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- THS ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'THS at ',ii,jj,' = ',THS(ii,jj)
-
-!C
-!CMP
-!C
-!C RAINC is "ACCUMULATED TOTAL CUMULUS PRECIPITATION"
-!C RAINNC is "ACCUMULATED TOTAL GRID SCALE PRECIPITATION"
-
- write(6,*) 'getting RAINC'
-
- VarName='PREC'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
-! CUPREC ( i, j ) = dummy ( i, j ) * 0.001
- PREC ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'PREC at ',ii,jj,' = ',PREC(ii,jj)
-
-! VarName='RAINC'
- VarName='CUPREC'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
-! CUPREC ( i, j ) = dummy ( i, j ) * 0.001
- CUPREC ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'CUPREC at ',ii,jj,' = ',CUPREC(ii,jj)
- write(6,*) 'getting RAINTOTAL'
-! VarName='RAINNC'
- VarName='ACPREC'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ACPREC( i, j ) = dummy ( i, j )
- ANCPRC ( i, j ) = ACPREC(I,J)-CUPREC(I,J)
- end do
- end do
- print*,'ACPREC at ',ii,jj,' = ',ACPREC(ii,jj)
- print*,'ANCPRC at ',ii,jj,' = ',ANCPRC(ii,jj)
-!
-! hoping to read instantanous convective precip rate soon, initialize it to spval
-! for now
-
- VarName='CPRATE'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- CPRATE(I,J)=dummy(i,j)
- enddo
- enddo
-
- VarName='CUPPT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- CUPPT ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'maxval CUPPT: ', maxval(DUMMY)
-
-! adding land surface precipitation accumulation for Yin's precip assimilation
-
- VarName='LSPA'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- LSPA ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'maxval LSPA: ', maxval(DUMMY)
-
-
- VarName='CLDEFI'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- CLDEFI ( i, j ) = dummy ( i, j )
- end do
- end do
- print*,'maxval CLDEFI: ', maxval(DUMMY)
-
-!
-! Very confusing story ...
-!
-! Retrieve htop and hbot => They are named CNVTOP, CNVBOT in the model and
-! with HBOTS,HTOPS (shallow conv) and HBOTD,HTOPD (deep conv) represent
-! the 3 sets of convective cloud base/top arrays tied to the frequency
-! that history files are written.
-!
-! IN THE *MODEL*, arrays HBOT,HTOP are similar to CNVTOP,CNVBOT but are
-! used in radiation and are tied to the frequency of radiation updates.
-!
-! For historical reasons model arrays CNVTOP,CNVBOT are renamed HBOT,HTOP
-! and manipulated throughout the post.
-
-! VarName='HTOP'
- VarName='CNVTOP'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- HTOP ( i, j ) = float(LM)-dummy(i,j)+1.0
- HTOP ( i, j ) = max(1.0,min(HTOP(I,J),float(LM)))
- end do
- end do
- print*,'maxval HTOP: ', maxval(DUMMY)
-
-! VarName='HBOT'
- VarName='CNVBOT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- HBOT ( i, j ) = float(LM)-dummy(i,j)+1.0
- HBOT ( i, j ) = max(1.0,min(HBOT(I,J),float(LM)))
- end do
- end do
- print*,'maxval HBOT: ', maxval(DUMMY)
-
- VarName='HTOPD'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- HTOPD ( i, j ) = float(LM)-dummy(i,j)+1.0
- end do
- end do
- print*,'maxval HTOPD: ', maxval(DUMMY)
-
- VarName='HBOTD'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- HBOTD ( i, j ) = float(LM)-dummy(i,j)+1.0
- end do
- end do
- print*,'maxval HBOTD: ', maxval(DUMMY)
-
- VarName='HTOPS'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- HTOPS ( i, j ) = float(LM)-dummy(i,j)+1.0
- end do
- end do
- print*,'maxval HTOPS: ', maxval(DUMMY)
-
- VarName='HBOTS'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- HBOTS ( i, j ) = float(LM)-dummy(i,j)+1.0
- end do
- end do
- print*,'maxval HBOTS: ', maxval(DUMMY)
-
- VarName='CLDFRA'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, &
- IM+1,1,JM+1,LM+1,IM,JS,JE,LM)
- do l = 1, lm
- do j = jsta_2l, jend_2u
- do i = 1, im
- CFR ( i, j, l ) = dum3d ( i, j, l )
- end do
- end do
- end do
-
-
- VarName='SR'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SR ( i, j ) = dummy(i,j)
- end do
- end do
- print*,'maxval SR: ', maxval(DUMMY)
-
-! call getVariable(fileName,DateStr,DataHandle,'RAINCV',DUMMY,
-! & IM,1,JM,1,IM,JS,JE,1)
-! do j = jsta_2l, jend_2u
-! do i = 1, im
-! CUPPT ( i, j ) = dummy ( i, j )* 0.001
-! end do
-! end do
-!
-! VarName='GSW'
- VarName='RSWIN'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- RSWIN ( i, j ) = dummy ( i, j )
-! if(abs(dummy(i,j))> 0.0)print*,'rswin=',dummy(i,j)
- end do
- end do
-
- VarName='RSWINC'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- RSWINC ( i, j ) = dummy ( i, j )
-! if(abs(dummy(i,j))> 0.0)print*,'rswin=',dummy(i,j)
- end do
- end do
-
-! read in zenith angle
- VarName='CZEN'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- CZEN ( i, j ) = dummy ( i, j )
-! if(abs(czen(i,j))> 0.0)print*,'czen=',czen(i,j)
- end do
- end do
-
- VarName='CZMEAN'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- CZMEAN ( i, j ) = dummy ( i, j )
-! if(abs(dummy(i,j))> 0.0)print*,'czmean=',dummy(i,j)
- end do
- end do
-
- VarName='RSWOUT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- RSWOUT ( i, j ) = dummy ( i, j )
-! if(abs(dummy(i,j))> 0.0)print*,'rswout=',dummy(i,j)
- end do
- end do
-
-! VarName='GLW'
- VarName='RLWIN'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- RLWIN ( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='RLWTOA'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- RLWTOA ( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='SIGT4'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SIGT4 ( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='RADOT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- RADOT ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! accumulated incoming short wave
- VarName='ASWIN'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ASWIN ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! accumulated outgoing short wave
- VarName='ASWOUT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ASWOUT ( i, j ) = dummy ( i, j )
-! if(abs(dummy(i,j))> 0.0)print*,'aswout=',dummy(i,j)
- end do
- end do
-
-! shortwave accumulation frequency
- VarName='NRDSW'
- call getIVariableN(fileName,DateStr,DataHandle,VarName,NRDSW, &
- 1,1,1,1,1,1,1,1)
- print*,'NRDSW in INITPOST_NMM=',NRDSW
-
- VarName='ARDSW'
- call getVariable(fileName,DateStr,DataHandle,VarName,ARDSW, &
- 1,1,1,1,1,1,1,1)
- print*,'ARDSW ARDLW in INITPOST_NMM=',ARDSW, ARDLW
-! accumulated incoming long wave
- VarName='ALWIN'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ALWIN ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! accumulated outgoing long wave
- VarName='ALWOUT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ALWOUT ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! longwave accumulation frequency
- VarName='NRDLW'
- call getIVariableN(fileName,DateStr,DataHandle,VarName,NRDLW, &
- 1,1,1,1,1,1,1,1)
- print*,'NRDLW= ',NRDLW
-
-! longwave accumulation counts
- VarName='ARDLW'
- call getVariable(fileName,DateStr,DataHandle,VarName,ARDLW, &
- 1,1,1,1,1,1,1,1)
-
-! obtain time averaged radition at the top of atmosphere
- VarName='ALWTOA'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ALWTOA ( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='ASWTOA'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ASWTOA ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! KRS: Add RSWTOA to radiation variable options
- VarName='RSWTOA'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- RSWTOA ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! KRS: RRTMG variables for HWRF
- VarName='SWUPT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SWUPT ( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='ACSWUPT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ACSWUPT ( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='SWDNT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SWDNT ( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='ACSWDNT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ACSWDNT ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! END KRS RRTMG Vars
-
-
-! VarName='TMN'
-! VarName='TG'
- VarName='TGROUND'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- TG ( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='SOILTB'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SOILTB ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! sensible heat fluxes
- VarName='TWBS'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- TWBS ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! accumulated sensible heat fluxes
-! VarName='HFX'
- VarName='SFCSHX'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SFCSHX ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! fluxes accumulation frequency
- VarName='NSRFC'
- call getIVariableN(fileName,DateStr,DataHandle,VarName,NSRFC, &
- 1,1,1,1,1,1,1,1)
- print*,'NSRFC= ',NSRFC
-! fluxes accumulation counts
- VarName='ASRFC'
- call getVariable(fileName,DateStr,DataHandle,VarName,ASRFC, &
- 1,1,1,1,1,1,1,1)
-
-! instantanous latent heat fluxes
- VarName='QWBS'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- QWBS ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! accumulated latent heat fluxes
-! VarName='QFX'
- VarName='SFCLHX'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SFCLHX ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! instantanous ground heat fluxes
- VarName='GRNFLX'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- GRNFLX ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! accumulated ground heat fluxes
- VarName='SUBSHX'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SUBSHX ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! accumulated ground heat fluxes
- VarName='POTEVP'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- POTEVP ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! VarName='SNOWC'
-! VarName='SNO'
- VarName='WEASD'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
-! do j = jsta_2l, jend_2u
-! do i = 1, im
-! SNO ( i, j ) = dummy ( i, j )
-! end do
-! end do
-
- VarName='SNO'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SNO ( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='SI'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SI ( i, j ) = dummy ( i, j )
- end do
- end do
-
-! snow cover
- VarName='PCTSNO'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- PCTSNO ( i, j ) = dummy ( i, j )
- if(dummy(i,j) > 1.0e-5)print*,'nonzero pctsno'
- end do
- end do
-
-
-! GET VEGETATION TYPE
-
-! call getVariable(fileName,DateStr,DataHandle,'IVGTYP',DUMMY
-! & ,IM,1,JM,1,IM,JS,JE,1)
-! print*,'sample VEG TYPE',DUMMY(20,20)
-! XLAND 1 land 2 sea
-! VarName='XLAND'
-
- VarName='IVGTYP'
- call getIVariableN(fileName,DateStr,DataHandle,VarName,IDUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- IVGTYP ( i, j ) = idummy ( i, j )
- end do
- end do
- print*,'MAX IVGTYP=', maxval(idummy)
-
- VarName='ISLTYP'
- call getIVariableN(fileName,DateStr,DataHandle,VarName,IDUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ISLTYP ( i, j ) = idummy ( i, j )
- end do
- end do
- print*,'MAX ISLTYP=', maxval(idummy)
-
- VarName='ISLOPE'
- call getIVariableN(fileName,DateStr,DataHandle,VarName,IDUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ISLOPE( i, j ) = idummy ( i, j )
- end do
- end do
-
- VarName='SM'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SM ( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='SICE'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- SICE ( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='ALBEDO'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ALBEDO( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='ALBASE'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- ALBASE( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='MXSNAL'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- MXSNAL( i, j ) = dummy ( i, j )
- end do
- end do
-
- VarName='EPSR'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- EPSR( i, j ) = dummy ( i, j )
- end do
- end do
-
-! VarName='XLAT'
- VarName='GLAT'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- f(i,j) = 1.454441e-4*sin(dummy(i,j))
- GDLAT ( i, j ) = dummy ( i, j ) * RTD
- end do
- end do
-! pos north
- print*,'GDLAT at ',ii,jj,' = ',GDLAT(ii,jj)
- print*,'read past GDLAT'
-! VarName='XLONG'
- VarName='GLON'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- GDLON ( i, j ) = dummy ( i, j ) * RTD
-! if(j==1 .or. j==jm)print*,'I,J,GDLON,GDLAT= ',i,j
-! 1 ,GDLON( i, j ),GDLAT ( i, j )
-! if(abs(GDLAT(i,j)-20.0)<0.5 .and. abs(GDLON(I,J)
-! 1 +157.0)<5.)print*
-! 2 ,'Debug:I,J,GDLON,GDLAT,SM,HGT,psfc= ',i,j,GDLON(i,j)
-! 3 ,GDLAT(i,j),SM(i,j),FIS(i,j)/G,PINT(I,j,lm+1)
- end do
- end do
- print*,'GDLON at ',ii,jj,' = ',GDLON(ii,jj)
- print*,'read past GDLON'
-! pos east
- call collect_loc(gdlat,dummy)
- get_dcenlat: if(me==0)then
- latstart=nint(dummy(1,1)*1000.) ! lower left
- latlast=nint(dummy(im,jm)*1000.) ! upper right
-
- icen=im/2 !center grid
- jcen=jm/2
-print *, 'dummy(icen,jcen) = ', dummy(icen,jcen)
-print *, 'dummy(icen-1,jcen) = ', dummy(icen-1,jcen)
-print *, 'dummy(icen+1,jcen) = ', dummy(icen+1,jcen)
-
- ! Grid navigation for copygb - R.Rozumalski
- latnm = nint(dummy(icen,jm)*1000.)
- latsm = nint(dummy(icen,1)*1000.)
-print *, 'latnm, latsm', latnm, latsm
-
- ! temporary patch for nmm wrf for moving nest
- ! cenlat = glat(im/2,jm/2) -Gopal
-
- if(mod(im,2)/=0)then !per Pyle, jm is always odd
- if(mod(jm+1,4)/=0)then
- dcenlat=dummy(icen,jcen)
- else
- dcenlat=0.5*(dummy(icen-1,jcen)+dummy(icen,jcen))
- end if
- else
- if(mod(jm+1,4)/=0)then
- dcenlat=0.5*(dummy(icen,jcen)+dummy(icen+1,jcen))
- else
- dcenlat=dummy(icen,jcen)
- end if
- end if
- endif get_dcenlat
- write(6,*) 'laststart,latlast,dcenlat B calling bcast= ', &
- latstart,latlast,dcenlat
- call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn)
- call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn)
- call mpi_bcast(dcenlat,1,MPI_REAL,0,mpi_comm_comp,irtn)
- write(6,*) 'laststart,latlast A calling bcast= ',latstart,latlast
-
- call collect_loc(gdlon,dummy)
- get_dcenlon: if(me==0)then
- lonstart=nint(dummy(1,1)*1000.)
- lonlast=nint(dummy(im,jm)*1000.)
-
- ! icen, jcen set above
-print *, 'lon dummy(icen,jcen) = ', dummy(icen,jcen)
-print *, 'lon dummy(icen-1,jcen) = ', dummy(icen-1,jcen)
-print *, 'lon dummy(icen+1,jcen) = ', dummy(icen+1,jcen)
-
- ! Grid navigation for copygb - R.Rozumalski
- lonem = nint(dummy(icen,jm)*1000.)
- lonwm = nint(dummy(icen,1)*1000.)
-
- if(mod(im,2)/=0)then !per Pyle, jm is always odd
- if(mod(jm+1,4)/=0)then
- cen1=dummy(icen,jcen)
- cen2=cen1
- else
- cen1=min(dummy(icen-1,jcen),dummy(icen,jcen))
- cen2=max(dummy(icen-1,jcen),dummy(icen,jcen))
- end if
- else
- if(mod(jm+1,4)/=0)then
- cen1=min(dummy(icen+1,jcen),dummy(icen,jcen))
- cen2=max(dummy(icen+1,jcen),dummy(icen,jcen))
- else
- cen1=dummy(icen,jcen)
- cen2=cen1
- end if
- end if
- ! Trahan fix: Pyle's code broke at the dateline.
- if(cen2-cen1>180) then
- ! We're near the dateline
- dcenlon=mod(0.5*(cen2+cen1+360)+3600+180,360.)-180.
- else
- ! We're not near the dateline. Use the original code,
- ! unmodified, to maintain bitwise identicality.
- dcenlon=0.5*(cen1+cen2)
- endif
- end if get_dcenlon ! rank 0
- write(6,*)'lonstart,lonlast,cenlon B calling bcast= ',lonstart, &
- lonlast,cenlon
- call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn)
- call mpi_bcast(lonlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn)
- call mpi_bcast(dcenlon,1,MPI_REAL,0,mpi_comm_comp,irtn)
- write(6,*)'lonstart,lonlast,cenlon A calling bcast= ',lonstart, &
- lonlast,cenlon
-
- if(me==0) then
- open(1013,file='this-domain-center.ksh.inc',form='formatted',status='unknown')
-1013 format(A,'=',F0.3)
- write(1013,1013) 'clat',dcenlat
- write(1013,1013) 'clon',dcenlon
- endif
-!
-! OBTAIN DX FOR NMM WRF
- VarName='DX_NMM'
- call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, &
- IM,1,JM,1,IM,JS,JE,1)
- do j = jsta_2l, jend_2u
- do i = 1, im
- DX ( i, j ) = dummy ( i, j )
- if(DX(i,j)<0.1)print*,'zero dx in INIT: I,J,DX= ',i,j &
- ,DX( i, j )
-! if(j==1 .or. j==jm)print*,'I,J,DX= ',i,j
-! 1 ,DX( i, j )
- end do
- end do
-
- varname='ETA1'
- write(6,*) 'call getVariable for : ', VarName
- call getVariable(fileName,DateStr,DataHandle,VarName,ETA1, &
- LM,1,1,1,LM,1,1,1)
-
- varname='ETA2'
- write(6,*) 'call getVariable for : ', VarName
- call getVariable(fileName,DateStr,DataHandle,VarName,ETA2, &
- LM,1,1,1,LM,1,1,1)
-
- open(75,file='ETAPROFILE.txt',form='formatted',status='unknown')
- DO L=1,lm+1
- IF(L == 1)THEN
- write(75,1020)L, 0., 0.
- ELSE
- write(75,1020)L, ETA1(lm+2-l), ETA2(lm+2-l)
- END IF
-! print*,'L, ETA1, ETA2= ',L, ETA1(l), ETA2(l)
- END DO
- 1020 format(I3,2E17.10)
- close (75)
-
-! physics calling frequency
- VarName='NPHS0'
- call getIVariableN(fileName,DateStr,DataHandle,VarName,NPHS, &
- 1,1,1,1,1,1,1,1)
- print*,'NPHS= ',NPHS
-! physics calling frequency
- VarName='NCLOD'
- call getIVariableN(fileName,DateStr,DataHandle,VarName,NCLOD, &
- 1,1,1,1,1,1,1,1)
-
-! physics calling frequency
- VarName='NPREC'
- call getIVariableN(fileName,DateStr,DataHandle,VarName,NPREC, &
- 1,1,1,1,1,1,1,1)
-
-! physics calling frequency
- VarName='NHEAT'
- call getIVariableN(fileName,DateStr,DataHandle,VarName,NHEAT, &
- 1,1,1,1,1,1,1,1)
- print*,'NHEAT= ',NHEAT
-
- ! Compute f_* arrays from q* arrays
- if(imp_physics==15) then
- print *,'Convert from Q arrays to F arrays for advected Ferrier.'
- call etamp_q2f(QRIMEF,QQI,QQR,QQW,CWM,F_RAIN,F_ICE,F_RIMEF,T)
- endif
-!
-! ncdump -h
-
-!!
-!!
-!!
- write(6,*) 'filename in INITPOST=', filename,' is'
-
-! status=nf_open(filename,NF_NOWRITE,ncid)
-! write(6,*) 'returned ncid= ', ncid
-! status=nf_get_att_real(ncid,varid,'DX',tmp)
-! dxval=int(tmp)
-! status=nf_get_att_real(ncid,varid,'DY',tmp)
-! dyval=int(tmp)
-! status=nf_get_att_real(ncid,varid,'CEN_LAT',tmp)
-! cenlat=int(1000.*tmp)
-! status=nf_get_att_real(ncid,varid,'CEN_LON',tmp)
-! cenlon=int(1000.*tmp)
-! status=nf_get_att_real(ncid,varid,'TRUELAT1',tmp)
-! truelat1=int(1000.*tmp)
-! status=nf_get_att_real(ncid,varid,'TRUELAT2',tmp)
-! truelat2=int(1000.*tmp)
-! status=nf_get_att_real(ncid,varid,'MAP_PROJ',tmp)
-! maptype=int(tmp)
-! status=nf_close(ncid)
-
-! dxval=30000.
-! dyval=30000.
-!
-! write(6,*) 'dxval= ', dxval
-! write(6,*) 'dyval= ', dyval
-! write(6,*) 'cenlat= ', cenlat
-! write(6,*) 'cenlon= ', cenlon
-! write(6,*) 'truelat1= ', truelat1
-! write(6,*) 'truelat2= ', truelat2
-! write(6,*) 'maptype is ', maptype
-!
- call ext_ncd_get_dom_ti_real(DataHandle,'DX',tmp, &
- 1,ioutcount,istatus)
- dxval=nint(tmp*1000.) ! E-grid dlamda in degree
- write(6,*) 'dxval= ', dxval
-
- call ext_ncd_get_dom_ti_real(DataHandle,'DY',tmp, &
- 1,ioutcount,istatus)
- dyval=nint(tmp*1000.)
- write(6,*) 'dyval= ', dyval
-
- call ext_ncd_get_dom_ti_real(DataHandle,'CEN_LAT',tmp, &
- 1,ioutcount,istatus)
- cenlat=nint(tmp*1000.) ! E-grid dlamda in degree
- write(6,*) 'cenlat= ', cenlat
-
- call ext_ncd_get_dom_ti_real(DataHandle,'CEN_LON',tmp, &
- 1,ioutcount,istatus)
- cenlon=nint(tmp*1000.) ! E-grid dlamda in degree
- write(6,*) 'cenlon= ', cenlon
-
-! JW call ext_ncd_get_dom_ti_real(DataHandle,'TRUELAT1',tmp
-! JW + ,1,ioutcount,istatus)
-! JW truelat1=nint(1000.*tmp)
-! JW write(6,*) 'truelat1= ', truelat1
-! JW call ext_ncd_get_dom_ti_real(DataHandle,'TRUELAT2',tmp
-! JW + ,1,ioutcount,istatus)
-! JW truelat2=nint(1000.*tmp)
-! JW write(6,*) 'truelat2= ', truelat2
- call ext_ncd_get_dom_ti_integer(DataHandle,'MAP_PROJ',itmp, &
- 1,ioutcount,istatus)
- maptype=itmp
- gridtype = 'E'
- write(6,*) 'maptype, gridtype ', maptype, gridtype
- gridtype='E'
-
- call ext_ncd_get_dom_ti_integer(DataHandle,'I_PARENT_START',itmp, &
- 1,ioutcount,istatus)
- i_parent_start=itmp
-
- call ext_ncd_get_dom_ti_integer(DataHandle,'J_PARENT_START',itmp, &
- 1,ioutcount,istatus)
- j_parent_start=itmp
-
- do j = jsta_2l, jend_2u
- do i = 1, im
-! DX ( i, j ) = dxval
- DY ( i, j ) = dyval*DTR*ERAD*0.001
- end do
- end do
-
-! generate look up table for lifted parcel calculations
-
- THL=210.
- PLQ=70000.
-
- CALL TABLE(PTBL,TTBL,PT, &
- RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0)
-
- CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q)
-
-!
-!
- IF(ME==0)THEN
- WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: '
- WRITE(6,51) (SPL(L),L=1,LSM)
- 50 FORMAT(14(F4.1,1X))
- 51 FORMAT(8(F8.1,1X))
- ENDIF
-!
-! COMPUTE DERIVED TIME STEPPING CONSTANTS.
-!
- call ext_ncd_get_dom_ti_real(DataHandle,'DT',tmp, &
- 1,ioutcount,istatus)
- DT=tmp
- print*,'DT= ',DT
- DTQ2 = DT * NPHS
- TSPH = 3600./DT
-
- TSRFC=float(NSRFC)/TSPH
- IF(NSRFC==0)TSRFC=float(ifhr) !in case buket does not get emptied
- TRDLW=float(NRDLW)/TSPH
- IF(NRDLW==0)TRDLW=float(ifhr) !in case buket does not get emptied
- TRDSW=float(NRDSW)/TSPH
- IF(NRDSW==0)TRDSW=float(ifhr) !in case buket does not get emptied
- THEAT=float(NHEAT)/TSPH
- IF(NHEAT==0)THEAT=float(ifhr) !in case buket does not get emptied
- TCLOD=float(NCLOD)/TSPH
- IF(NCLOD==0)TCLOD=float(ifhr) !in case buket does not get emptied
- TPREC=float(NPREC)/TSPH
- IF(NPREC==0)TPREC=float(ifhr) !in case buket does not get emptied
- print*,'TSRFC TRDLW TRDSW= ',TSRFC, TRDLW, TRDSW
-
-!how am i going to get this information?
-! NPREC = INT(TPREC *TSPH+D50)
-! NHEAT = INT(THEAT *TSPH+D50)
-! NCLOD = INT(TCLOD *TSPH+D50)
-! NRDSW = INT(TRDSW *TSPH+D50)
-! NRDLW = INT(TRDLW *TSPH+D50)
-! NSRFC = INT(TSRFC *TSPH+D50)
-!how am i going to get this information?
-!
-! IF(ME==0)THEN
-! WRITE(6,*)' '
-! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS'
-! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC
-! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW
-! ENDIF
-!
-! COMPUTE DERIVED MAP OUTPUT CONSTANTS.
- DO L = 1,LSM
- ALSL(L) = ALOG(SPL(L))
- END DO
-!
- if(submodelname == 'NEST') then
- print *,'NMM NEST mode: use projection center as projection center'
- elseif(submodelname == 'MOAD') then
- print *,'NMM MOAD mode: use domain center as projection center'
- CENLAT=NINT(DCENLAT*1000)
- CENLON=NINT(DCENLON*1000)
- elseif(i_parent_start>1 .or. j_parent_start>1) then
- print *,'No submodel specified for nested domain. Using projection center as projection center.'
- else
- print *,'No submodel specified for MOAD. Using domain center as projection center'
- endif
-
-
- if(me==0)then
- ! write out copygb_gridnav.txt
- ! provided by R.Rozumalski - NWS
-
- inav=10
-
- TRUELAT1 = CENLAT
- TRUELAT2 = CENLAT
-
- IFDX = NINT (dxval*107.)
- IFDY = NINT (dyval*110.)
-
- open(inav,file='copygb_gridnav.txt',form='formatted', &
- status='unknown')
-
- print *, ' MAPTYPE :',maptype
- print *, ' IM :',IM*2-1
- print *, ' JM :',JM
- print *, ' LATSTART :',LATSTART
- print *, ' LONSTART :',LONSTART
- print *, ' CENLAT :',CENLAT
- print *, ' CENLON :',CENLON
- print *, ' TRUELAT2 :',TRUELAT2
- print *, ' TRUELAT1 :',TRUELAT1
- print *, ' DX :',IFDX*0.001
- print *, ' DY :',IFDY*0.001
-
- IF(MAPTYPE==0 .OR. MAPTYPE==203)THEN !A STAGGERED E-GRID
-
- IMM = 2*IM-1
- IDXAVE = ( IFDY + IFDX ) * 0.5
-
- ! If the Center Latitude of the domain is located within 15 degrees
- ! of the equator then use a a regular Lat/Lon navigation for the
- ! remapped grid in copygb; otherwise, use a Lambert conformal. Make
- ! sure to specify the correct pole for the S. Hemisphere (LCC).
- !
- IF ( abs(CENLAT)>15000) THEN
- write(6,*)' Copygb LCC Navigation Information'
- IF (CENLAT >0) THEN ! Northern Hemisphere
- write(6,1000) IMM,JM,LATSTART,LONSTART,CENLON, &
- IFDX,IFDY,CENLAT,CENLAT
- write(inav,1000) IMM,JM,LATSTART,LONSTART,CENLON, &
- IFDX,IFDY,CENLAT,CENLAT
- ELSE ! Southern Hemisphere
- write(6,1001) IMM,JM,LATSTART,LONSTART,CENLON, &
- IFDX,IFDY,CENLAT,CENLAT
- write(inav,1001) IMM,JM,LATSTART,LONSTART,CENLON, &
- IFDX,IFDY,CENLAT,CENLAT
- END IF
- ELSE
- dlat = (latnm-latsm)/(JM-1)
- nlat = INT (dlat)
-
- if (lonem < 0) lonem = 360000. + lonem
- if (lonwm < 0) lonwm = 360000. + lonwm
-
- dlon = lonem-lonwm
- if (dlon < 0.) dlon = dlon + 360000.
- dlon = (dlon)/(IMM-1)
- nlon = INT (dlon)
-
- write(6,*)' Copygb Lat/Lon Navigation Information'
- write(6,2000) IMM,JM,latsm,lonwm,latnm,lonem,nlon,nlat
- write(inav,2000) IMM,JM,latsm,lonwm,latnm,lonem,nlon,nlat
- ENDIF
- close(inav)
-
- 1000 format('255 3 ',2(I3,x),I6,x,I7,x,'8 ',I7,x,2(I6,x),'0 64', &
- 2(x,I6))
- 1001 format('255 3 ',2(I3,x),I6,x,I7,x,'8 ',I7,x,2(I6,x),'128 64', &
- 2(x,I6),' -90000 0')
- 2000 format('255 0 ',2(I3,x),2(I7,x),'8 ',2(I7,x),2(I7,x),'64')
- END IF ! maptype
-
- !HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN
- igdout=110
- if (maptype == 1)THEN ! Lambert conformal
- WRITE(igdout)3
- WRITE(6,*)'igd(1)=',3
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)8
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)0
- WRITE(igdout)64
-! JW WRITE(igdout)TRUELAT2
-! JW WRITE(igdout)TRUELAT1
- WRITE(igdout)255
- ELSE IF(MAPTYPE == 2)THEN !Polar stereographic
- WRITE(igdout)5
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)8
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)0
- WRITE(igdout)64
-! JW WRITE(igdout)TRUELAT2 !Assume projection at +-90
-! JW WRITE(igdout)TRUELAT1
- WRITE(igdout)255
- ! Note: The calculation of the map scale factor at the standard
- ! lat/lon and the PSMAPF
- ! Get map factor at 60 degrees (N or S) for PS projection, which will
- ! be needed to correctly define the DX and DY values in the GRIB GDS
- if (TRUELAT1 < 0.) THEN
- LAT = -60.
- else
- LAT = 60.
- end if
-
- CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF)
-
- ELSE IF(MAPTYPE == 3)THEN !Mercator
- WRITE(igdout)1
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)8
- WRITE(igdout)latlast
- WRITE(igdout)lonlast
-! JW WRITE(igdout)TRUELAT1
- WRITE(igdout)0
- WRITE(igdout)64
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)255
- ELSE IF(MAPTYPE==0 .OR. MAPTYPE==203)THEN !A STAGGERED E-GRID
- WRITE(igdout)203
- WRITE(igdout)im
- WRITE(igdout)jm
- WRITE(igdout)LATSTART
- WRITE(igdout)LONSTART
- WRITE(igdout)136
- WRITE(igdout)CENLAT
- WRITE(igdout)CENLON
- WRITE(igdout)DXVAL
- WRITE(igdout)DYVAL
- WRITE(igdout)64
- WRITE(igdout)0
- WRITE(igdout)0
- WRITE(igdout)0
-
-! following for hurricane wrf post
- open(inav,file='copygb_hwrf.txt',form='formatted', &
- status='unknown')
- LATEND=LATSTART+(JM-1)*dyval
- LONEND=LONSTART+(IMM-1)*dxval
- write(10,1010) IMM,JM,LATSTART,LONSTART,LATEND,LONEND, &
- dxval,dyval
-
-1010 format('255 0 ',2(I3,x),I6,x,I7,x,'136 ',I6,x,I7,x, &
- 2(I6,x),'64')
- close (inav)
-
- END IF
- end if
-!
-!
-! close up shop
- call ext_ncd_ioclose ( DataHandle, Status )
-
- RETURN
- END
diff --git a/sorc/ncep_post.fd/LFMFLD.f b/sorc/ncep_post.fd/LFMFLD.f
index a5d83919b..9aeefc635 100644
--- a/sorc/ncep_post.fd/LFMFLD.f
+++ b/sorc/ncep_post.fd/LFMFLD.f
@@ -1,71 +1,46 @@
!> @file
-! . . .
-!> SUBPROGRAM: LFMFLD COMPUTES LAYER MEAN LFM FIELDS
-!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22
-!!
-!! ABSTRACT:
-!! THIS ROUTINE COMPUTES THREE LAYER MEAN RELATIVE HUMIDITIES
-!! AND A PRECIPITABLE WATER FIELD FROM ETA LEVEL DATA. THE
-!! COMPUTED FIELDS ARE INTENDED TO MIMIC SIMILAR FIELDS COM-
-!! PUTED BY THE LFM. THE ALGORITHM USED HERE IS FAIRLY PRI-
-!! MATIVE. IN EACH COLUMN ABOVE A MASS POINT ON THE ETA GRID
-!! WE SET THE FOLLOWING TARGET PRESSURES:
-!! SIGMA LAYER 1.00 PRESSURE: SURFACE PRESSURE
-!! SIGMA LAYER 0.66 PRESSURE: 0.50 * SURFACE PRESSURE
-!! SIGMA LAYER 0.33 PRESSURE: 0.4356 * SURFACE PRESSURE
-!! GIVEN THESE PRESSURES A SURFACE UP SUMMATION IS MADE OF
-!! RELATIVE HUMIDITY AND/OR PRECIPITABLE WATER BETWEEN THESE
-!! TARGET PRESSURES. EACH TERM IN THE SUMMATION IS WEIGHTED
-!! BY THE THICKNESS OF THE ETA LAYER. THE FINAL LAYER MEAN
-!! IS THIS SUM NORMALIZED BY THE TOTAL DEPTH OF THE LAYER.
-!! THERE IS, OBVIOUSLY, NO NORMALIZATION FOR PRECIPITABLE WATER.
-!!
-!!
-!! PROGRAM HISTORY LOG:
-!! 92-12-22 RUSS TREADON
-!! 93-07-27 RUSS TREADON - MODIFIED SUMMATION LIMITS FROM
-!! 0.66*PSFC TO 0.75*PSFC AND 0.33*PSFC
-!! TO 0.50*PSFC, WHERE PSFC IS THE
-!! SURFACES PRESSURE. THE REASON FOR
-!! THIS CHANGE WAS RECOGNITION THAT IN
-!! THE LFM 0.33 AND 0.66 WERE MEASURED
-!! FROM THE SURFACE TO THE TROPOPAUSE,
-!! NOT THE TOP OF THE MODEL.
-!! 93-09-13 RUSS TREADON - RH CALCULATIONS WERE MADE INTERNAL
-!! TO THE ROUTINE.
-!! 96-03-04 MIKE BALDWIN - CHANGE PW CALC TO INCLUDE CLD WTR
-!! 98-06-16 T BLACK - CONVERSION FROM 1-D TO 2-D
-!! 98-08-17 MIKE BALDWIN - COMPUTE RH OVER ICE
-!! 98-12-22 MIKE BALDWIN - BACK OUT RH OVER ICE
-!! 00-01-04 JIM TUCCILLO - MPI VERSION
-!! 02-04-24 MIKE BALDWIN - WRF VERSION
-!! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT
-!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE
-!!
-!!
-!! USAGE: CALL LFMFLD(RH3310,RH6610,RH3366,PW3310)
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! RH3310 - SIGMA LAYER 0.33-1.00 MEAN RELATIVE HUMIDITY.
-!! RH6610 - SIGMA LAYER 0.66-1.00 MEAN RELATIVE HUMIDITY.
-!! RH3366 - SIGMA LAYER 0.33-0.66 MEAN RELATIVE HUMIDITY.
-!! PW3310 - SIGMA LAYER 0.33-1.00 PRECIPITABLE WATER.
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! LIBRARY:
-!! COMMON -
-!! MAPOT
-!! LOOPS
-!! OPTIONS
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
+!> @brief lfmfld() computes layer mean LFM fields.
+!>
+!> This routine computes three layer mean relative humidities
+!> and a precipitable water field from ETA level data. The
+!> computed fields are intended to mimic similar fields com-
+!> puted by the LFM. The algorithm used here is fairly pri-
+!> mative.
+!>
+!> In each column above a mass point on the ETA grid we set the following target pressures:
+!> Sigma layer 1.00 pressure: Surface pressure
+!> Sigma layer 0.66 pressure: 0.50 * Surface pressure
+!> Sigma layer 0.33 pressure: 0.4356 * Surface pressure
+!>
+!> Given there pressures a surface up summation is made of
+!> relative humidity and/or precipitable water between these
+!> target pressures. Each term in the summation is weighted
+!> By the thickness of the ETA layer. The final layer mean
+!> is this sum normalized by the total depth of the layer.
+!> There is, obviously, no normalization for precipitable water.
+!>
+!> @param[out] RH3310 Sigma layer 0.33-1.00 mean relative humidity.
+!> @param[out] RH6610 Sigma layer 0.66-1.00 mean relative humidity.
+!> @param[out] RH3366 Sigma layer 0.33-0.66 mean relative humidity.
+!> @param[out] PW3310 Sigma layer 0.33-1.00 precipitable water.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1992-12-22 | Russ Treadon | Initial
+!> 1993-07-27 | Russ Treadon | Modified summation limits from 0.66*PSFC to 0.75*PSFC and 0.33*PSFC to 0.50*PSFC, where PSFC is the surfaces pressure. The reason for this change was recognition that in the LFM 0.33 and 0.66 were measured from the surface to the tropopause not the top of the model.
+!> 1993-09-13 | Russ Treadon | RH calculations were made internal to the routine.
+!> 1996-03-04 | Mike Baldwin | Change PW CALC to include CLD WTR
+!> 1998-06-16 | T Black | Conversion from 1-D to 2-D
+!> 1998-08-17 | Mike Baldwin | Compute RH over ice
+!> 1998-12-22 | Mike Baldwin | Back out RH over ice
+!> 2000-01-04 | Jim Tuccillo | MPI Version
+!> 2002-04-24 | Mike Baldwin | WRF Version
+!> 2019-10-30 | Bo Cui | Remove "GOTO" statement
+!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS Module
+!> 2021-10-14 | JESSE MENG | 2D DECOMPOSITION
+!>
+!> @author Russ Treadon W/NP2 @date 1992-12-22
SUBROUTINE LFMFLD(RH3310,RH6610,RH3366,PW3310)
!
@@ -73,7 +48,7 @@ SUBROUTINE LFMFLD(RH3310,RH6610,RH3366,PW3310)
use vrbls3d, only: pint, alpint, zint, t, q, cwm
use masks, only: lmh
use params_mod, only: d00, d50, pq0, a2, a3, a4, h1, d01, gi
- use ctlblk_mod, only: jsta, jend, modelname, spval, im
+ use ctlblk_mod, only: jsta, jend, modelname, spval, im, ista, iend
use physcons_post, only: con_rd, con_rv, con_eps, con_epsm1
use upp_physics, only: FPVSNEW
@@ -86,8 +61,8 @@ SUBROUTINE LFMFLD(RH3310,RH6610,RH3366,PW3310)
! DECLARE VARIABLES.
!
REAL ALPM, DZ, ES, PM, PWSUM, QM, QS, TM, DP, RH
- REAL,dimension(IM,jsta:jend),intent(inout) :: RH3310, RH6610, RH3366
- REAL,dimension(IM,jsta:jend),intent(inout) :: PW3310
+ REAL,dimension(ista:iend,jsta:jend),intent(inout) :: RH3310, RH6610, RH3366
+ REAL,dimension(ista:iend,jsta:jend),intent(inout) :: PW3310
real Z3310,Z6610,Z3366,P10,P33,P66
integer I,J,L,LLMH
!
@@ -98,7 +73,7 @@ SUBROUTINE LFMFLD(RH3310,RH6610,RH3366,PW3310)
! LOOP OVER HORIZONTAL GRID.
!
DO 30 J=JSTA,JEND
- DO 30 I=1,IM
+ DO 30 I=ISTA,IEND
!
! ZERO VARIABLES.
RH3310(I,J) = D00
diff --git a/sorc/ncep_post.fd/LFMFLD_GFS.f b/sorc/ncep_post.fd/LFMFLD_GFS.f
index e89436e39..70ee6e438 100644
--- a/sorc/ncep_post.fd/LFMFLD_GFS.f
+++ b/sorc/ncep_post.fd/LFMFLD_GFS.f
@@ -1,74 +1,47 @@
!> @file
-! . . .
-!> SUBPROGRAM: LFMFLD COMPUTES LAYER MEAN LFM FIELDS
-!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22
-!!
-!! ABSTRACT:
-!! THIS ROUTINE COMPUTES THREE LAYER MEAN RELATIVE HUMIDITIES
-!! AND A PRECIPITABLE WATER FIELD FROM ETA LEVEL DATA. THE
-!! COMPUTED FIELDS ARE INTENDED TO MIMIC SIMILAR FIELDS COM-
-!! PUTED BY THE LFM. THE ALGORITHM USED HERE IS FAIRLY PRI-
-!! MATIVE. IN EACH COLUMN ABOVE A MASS POINT ON THE ETA GRID
-!! WE SET THE FOLLOWING TARGET PRESSURES:
-!! SIGMA LAYER 1.00 PRESSURE: SURFACE PRESSURE
-!! SIGMA LAYER 0.66 PRESSURE: 0.50 * SURFACE PRESSURE
-!! SIGMA LAYER 0.33 PRESSURE: 0.4356 * SURFACE PRESSURE
-!! GIVEN THESE PRESSURES A SURFACE UP SUMMATION IS MADE OF
-!! RELATIVE HUMIDITY AND/OR PRECIPITABLE WATER BETWEEN THESE
-!! TARGET PRESSURES. EACH TERM IN THE SUMMATION IS WEIGHTED
-!! BY THE THICKNESS OF THE ETA LAYER. THE FINAL LAYER MEAN
-!! IS THIS SUM NORMALIZED BY THE TOTAL DEPTH OF THE LAYER.
-!! THERE IS, OBVIOUSLY, NO NORMALIZATION FOR PRECIPITABLE WATER.
-!!
-!!
-!! PROGRAM HISTORY LOG:
-!! 92-12-22 RUSS TREADON
-!! 93-07-27 RUSS TREADON - MODIFIED SUMMATION LIMITS FROM
-!! 0.66*PSFC TO 0.75*PSFC AND 0.33*PSFC
-!! TO 0.50*PSFC, WHERE PSFC IS THE
-!! SURFACES PRESSURE. THE REASON FOR
-!! THIS CHANGE WAS RECOGNITION THAT IN
-!! THE LFM 0.33 AND 0.66 WERE MEASURED
-!! FROM THE SURFACE TO THE TROPOPAUSE,
-!! NOT THE TOP OF THE MODEL.
-!! 93-09-13 RUSS TREADON - RH CALCULATIONS WERE MADE INTERNAL
-!! TO THE ROUTINE.
-!! 96-03-04 MIKE BALDWIN - CHANGE PW CALC TO INCLUDE CLD WTR
-!! 98-06-16 T BLACK - CONVERSION FROM 1-D TO 2-D
-!! 98-08-17 MIKE BALDWIN - COMPUTE RH OVER ICE
-!! 98-12-22 MIKE BALDWIN - BACK OUT RH OVER ICE
-!! 00-01-04 JIM TUCCILLO - MPI VERSION
-!! 02-04-24 MIKE BALDWIN - WRF VERSION
-!! 06-11-06 H CHUANG - MODIFY TO OUTPUT GFS LFM FIELDS WHICH
-!! HAVE DIFFERENT THICKNESS AS MESO AND USE DP
-!! RATHER THAN DZ
-!! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT
-!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE
-!!
-!!
-!! USAGE: CALL LFMFLD(RH3310,RH6610,RH3366,PW3310)
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! RH3310 - SIGMA LAYER 0.33-1.00 MEAN RELATIVE HUMIDITY.
-!! RH6610 - SIGMA LAYER 0.66-1.00 MEAN RELATIVE HUMIDITY.
-!! RH3366 - SIGMA LAYER 0.33-0.66 MEAN RELATIVE HUMIDITY.
-!! PW3310 - SIGMA LAYER 0.33-1.00 PRECIPITABLE WATER.
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! LIBRARY:
-!! COMMON -
-!! MAPOT
-!! LOOPS
-!! OPTIONS
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
+!> @brief lfmfld_gfs() computes layer mean LFM fields.
+!>
+!> This routine computes three layer mean relative humidities
+!> and a precipitable water field from ETA level data. The
+!> computed fields are intended to mimic similar fields com-
+!> puted by the LFM. The algorithm used here is fairly pri-
+!> mative.
+!>
+!> In each column above a mass point on the ETA grid we set the following target pressures:
+!> Sigma layer 1.00 pressure: Surface pressure
+!> Sigma layer 0.66 pressure: 0.50 * Surface pressure
+!> Sigma layer 0.33 pressure: 0.4356 * Surface pressure
+!>
+!> Given there pressures a surface up summation is made of
+!> relative humidity and/or precipitable water between these
+!> target pressures. Each term in the summation is weighted
+!> By the thickness of the ETA layer. The final layer mean
+!> is this sum normalized by the total depth of the layer.
+!> There is, obviously, no normalization for precipitable water.
+!>
+!> @param[out] RH3310 Sigma layer 0.33-1.00 mean relative humidity.
+!> @param[out] RH6610 Sigma layer 0.66-1.00 mean relative humidity.
+!> @param[out] RH3366 Sigma layer 0.33-0.66 mean relative humidity.
+!> @param[out] PW3310 Sigma layer 0.33-1.00 precipitable water.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1992-12-22 | Russ Treadon | Initial
+!> 1993-07-27 | Russ Treadon | Modified summation limits from 0.66*PSFC to 0.75*PSFC and 0.33*PSFC to 0.50*PSFC, where PSFC is the surfaces pressure. The reason for this change was recognition that in the LFM 0.33 and 0.66 were measured from the surface to the tropopause not the top of the model.
+!> 1993-09-13 | Russ Treadon | RH calculations were made internal to the routine.
+!> 1996-03-04 | Mike Baldwin | Change PW CALC to include CLD WTR
+!> 1998-06-16 | T Black | Conversion from 1-D to 2-D
+!> 1998-08-17 | Mike Baldwin | Compute RH over ice
+!> 1998-12-22 | Mike Baldwin | Back out RH over ice
+!> 2000-01-04 | Jim Tuccillo | MPI Version
+!> 2002-04-24 | Mike Baldwin | WRF Version
+!> 2006-11-06 | H CHUANG | Modify to output GFS LFM fields which have different thickness as MESO and use DP rather than DZ
+!> 2019-10-30 | Bo Cui | Remove "GOTO" statement
+!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS Module
+!> 2021-10-14 | JESSE MENG | 2D DECOMPOSITION
+!>
+!> @author Russ Treadon W/NP2 @date 1992-12-22
SUBROUTINE LFMFLD_GFS(RH4410,RH7294,RH4472,RH3310)
!
@@ -76,7 +49,7 @@ SUBROUTINE LFMFLD_GFS(RH4410,RH7294,RH4472,RH3310)
use vrbls3d, only: pint, q, t, pmid
use masks, only: lmh
use params_mod, only: d00
- use ctlblk_mod, only: jsta, jend, spval, im
+ use ctlblk_mod, only: jsta, jend, spval, im, ista, iend
use upp_physics, only: FPVSNEW
!
implicit none
@@ -92,7 +65,7 @@ SUBROUTINE LFMFLD_GFS(RH4410,RH7294,RH4472,RH3310)
! DECLARE VARIABLES.
!
REAL ALPM, DZ, ES, PM, PWSUM, QM, QS
- REAL,dimension(IM,jsta:jend),intent(out) :: RH4410, RH7294, RH4472 &
+ REAL,dimension(ista:iend,jsta:jend),intent(out) :: RH4410, RH7294, RH4472 &
,RH3310
!
integer I,J,L,LLMH
@@ -106,7 +79,7 @@ SUBROUTINE LFMFLD_GFS(RH4410,RH7294,RH4472,RH3310)
! LOOP OVER HORIZONTAL GRID.
!
DO 30 J=JSTA,JEND
- DO 30 I=1,IM
+ DO 30 I=ISTA,IEND
!
! ZERO VARIABLES.
RH4410(I,J) = D00
diff --git a/sorc/ncep_post.fd/MAPSSLP.f b/sorc/ncep_post.fd/MAPSSLP.f
index 6eda2b217..6666631cd 100644
--- a/sorc/ncep_post.fd/MAPSSLP.f
+++ b/sorc/ncep_post.fd/MAPSSLP.f
@@ -10,7 +10,8 @@ SUBROUTINE MAPSSLP(TPRES)
!
!-----------------------------------------------------------------------
use ctlblk_mod, only: jsta, jend, spl, smflag, lm, im, jsta_2l, jend_2u, &
- lsm, jm, grib, spval
+ lsm, jm, grib, spval, &
+ ista, iend, ista_2l, iend_2u
use gridspec_mod, only: maptype, dxval
use vrbls3d, only: pmid, t, pint
use vrbls2d, only: pslp, fis
@@ -21,11 +22,11 @@ SUBROUTINE MAPSSLP(TPRES)
!
INCLUDE "mpif.h"
!
- REAL TPRES(IM,JSTA_2L:JEND_2U,LSM)
+ REAL TPRES(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LSM)
real LAPSES, EXPo,EXPINV,TSFCNEW
- REAL,dimension(im, jsta_2l:jend_2u) :: T700
+ REAL,dimension(ista_2l:iend_2u, jsta_2l:jend_2u) :: T700
real,dimension(im,2) :: sdummy
REAL,dimension(im,jm) :: GRID1, TH700
INTEGER NSMOOTH
@@ -42,7 +43,7 @@ SUBROUTINE MAPSSLP(TPRES)
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(SPL(L) == 70000.)THEN
if(TPRES(I,J,L) 100.) THEN
@@ -112,7 +113,7 @@ SUBROUTINE MAPSSLP(TPRES)
CALL SMOOTH(GRID1,SDUMMY,IM,JM,0.5)
end do
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
PSLP(I,J)=GRID1(I,J)
ENDDO
ENDDO
diff --git a/sorc/ncep_post.fd/MDL2AGL.f b/sorc/ncep_post.fd/MDL2AGL.f
index b1f5254fa..55d97b07c 100644
--- a/sorc/ncep_post.fd/MDL2AGL.f
+++ b/sorc/ncep_post.fd/MDL2AGL.f
@@ -16,6 +16,7 @@
!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend)
!! 21-04-01 J MENG - computation on defined points only
!! 21-07-26 W Meng - Restrict computation from undefined grids
+!! 21-10-14 J MENG - 2D DECOMPOSITION
!!
!! USAGE: CALL MDL2P
!! INPUT ARGUMENT LIST:
@@ -61,7 +62,8 @@ SUBROUTINE MDL2AGL
use params_mod, only: dbzmin, small, eps, rd
use ctlblk_mod, only: spval, lm, modelname, grib, cfld, fld_info, datapd,&
ifhr, global, jsta_m, jend_m, mpi_comm_comp, &
- jsta_2l, jend_2u, im, jm, jsta, jend, imp_physics
+ jsta_2l, jend_2u, im, jm, jsta, jend, imp_physics, &
+ ista, iend, ista_2l, iend_2u, ista_m, iend_m
use rqstfld_mod, only: iget, lvls, iavblfld, lvlsxml, id
use gridspec_mod, only: gridtype
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -77,10 +79,10 @@ SUBROUTINE MDL2AGL
! DECLARE VARIABLES.
!
LOGICAL IOOMG,IOALL
- REAL,dimension(im,jsta_2l:jend_2u) :: grid1
- REAL,dimension(im,jsta_2l:jend_2u) :: UAGL, VAGL, tagl, pagl, qagl
+ REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: grid1
+ REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: UAGL, VAGL, tagl, pagl, qagl
!
- INTEGER,dimension(im,jsta_2l:jend_2u) :: NL1X
+ INTEGER,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: NL1X
integer,dimension(jm) :: IHE, IHW
INTEGER LXXX,IERR, maxll, minll
INTEGER ISTART,ISTOP,JSTART,JSTOP
@@ -100,7 +102,7 @@ SUBROUTINE MDL2AGL
!
! REAL C1D(IM,JM),QW1(IM,JM),QI1(IM,JM),QR1(IM,JM)
! &, QS1(IM,JM) ,DBZ1(IM,JM)
- REAL,dimension(im,jsta:jend) :: DBZ1, DBZR1, DBZI1, DBZC1, dbz1log
+ REAL,dimension(ista:iend,jsta:jend) :: DBZ1, DBZR1, DBZI1, DBZC1, dbz1log
real,dimension(lagl) :: ZAGL
real,dimension(lagl2) :: ZAGL2, ZAGL3
real PAGLU,PAGLL,TAGLU,TAGLL,QAGLU,QAGLL, pv, rho
@@ -149,10 +151,10 @@ SUBROUTINE MDL2AGL
IF (iget1 > 0 .or. iget2 > 0 .or. iget3 > 0 .or. iget4 > 0) then
!
jj=float(jsta+jend)/2.0
- ii=float(im)/3.0
+ ii=float(ista+iend)/3.0
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
DBZ1(I,J) = SPVAL
DBZR1(I,J) = SPVAL
DBZI1(I,J) = SPVAL
@@ -195,7 +197,7 @@ SUBROUTINE MDL2AGL
! DO 220 J=JSTA,JEND
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
LL = NL1X(I,J)
!---------------------------------------------------------------------
!*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC
@@ -281,13 +283,13 @@ SUBROUTINE MDL2AGL
IF((IGET(253)>0) )THEN
if(MODELNAME=='RAPR') then
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=DBZ1LOG(I,J)
ENDDO
ENDDO
else
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=DBZ1(I,J)
ENDDO
ENDDO
@@ -296,13 +298,13 @@ SUBROUTINE MDL2AGL
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(253))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(253))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Radar reflectivity from rain
IF((IGET(279)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=DBZR1(I,J)
ENDDO
ENDDO
@@ -310,13 +312,13 @@ SUBROUTINE MDL2AGL
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(279))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(279))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Radar reflectivity from all ice habits (snow + graupel + sleet, etc.)
IF((IGET(280)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=DBZI1(I,J)
ENDDO
ENDDO
@@ -324,13 +326,13 @@ SUBROUTINE MDL2AGL
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(280))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(280))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Radar reflectivity from parameterized convection
IF((IGET(281)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=DBZC1(I,J)
ENDDO
ENDDO
@@ -338,7 +340,7 @@ SUBROUTINE MDL2AGL
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(281))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(281))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!
@@ -355,7 +357,7 @@ SUBROUTINE MDL2AGL
!--- Max Derived Radar Reflectivity
IF((IGET(421)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=REFD_MAX(I,J)
ENDDO
ENDDO
@@ -370,14 +372,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat=0
endif
fld_info(cfld)%ntrange=1
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Derived Radar Reflectivity at -10C
IF((IGET(785)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=REFDM10C_MAX(I,J)
ENDDO
ENDDO
@@ -391,14 +393,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat=0
endif
fld_info(cfld)%ntrange=1
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Updraft Helicity
IF((IGET(420)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=UP_HELI_MAX(I,J)
ENDDO
ENDDO
@@ -412,14 +414,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 0
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Updraft Helicity 1-6 km
IF((IGET(700)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=UP_HELI_MAX16(I,J)
ENDDO
ENDDO
@@ -433,14 +435,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Min Updraft Helicity
IF((IGET(786)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=UP_HELI_MIN(I,J)
ENDDO
ENDDO
@@ -454,14 +456,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 0
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Min Updraft Helicity 1-6 km
IF((IGET(787)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=UP_HELI_MIN16(I,J)
ENDDO
ENDDO
@@ -475,14 +477,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Updraft Helicity 0-2 km
IF((IGET(788)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=UP_HELI_MAX02(I,J)
ENDDO
ENDDO
@@ -496,13 +498,13 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 0
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Min Updraft Helicity 0-2 km
IF((IGET(789)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=UP_HELI_MIN02(I,J)
ENDDO
ENDDO
@@ -516,14 +518,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Updraft Helicity 0-3 km
IF((IGET(790)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=UP_HELI_MAX03(I,J)
ENDDO
ENDDO
@@ -537,14 +539,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 0
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Min Updraft Helicity 0-3 km
IF((IGET(791)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=UP_HELI_MIN03(I,J)
ENDDO
ENDDO
@@ -558,14 +560,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Relative Vertical Vorticity 0-2 km
IF((IGET(792)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=REL_VORT_MAX(I,J)
ENDDO
ENDDO
@@ -579,14 +581,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 0
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Relative Vertical Vorticity 0-1 km
IF((IGET(793)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=REL_VORT_MAX01(I,J)
ENDDO
ENDDO
@@ -600,13 +602,13 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 0
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Relative Vertical Vorticity @ hybrid level 1
IF((IGET(890)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=REL_VORT_MAXHY1(I,J)
ENDDO
ENDDO
@@ -620,14 +622,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 0
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Hail Diameter in Column
IF((IGET(794)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=HAIL_MAX2D(I,J)
ENDDO
ENDDO
@@ -641,14 +643,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Hail Diameter at k=1
IF((IGET(795)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=HAIL_MAXK1(I,J)
ENDDO
ENDDO
@@ -662,7 +664,7 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
@@ -671,7 +673,7 @@ SUBROUTINE MDL2AGL
! (J. Kenyon/GSD, added 1 May 2019)
IF((IGET(728)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=HAIL_MAXHAILCAST(I,J)/1000.0 ! convert mm to m
ENDDO
ENDDO
@@ -685,14 +687,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Column Integrated Graupel
IF((IGET(429)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=GRPL_MAX(I,J)
ENDDO
ENDDO
@@ -706,14 +708,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Lightning Threat 1
IF((IGET(702)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=LTG1_MAX(I,J)
ENDDO
ENDDO
@@ -727,14 +729,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Lightning Threat 2
IF((IGET(703)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=LTG2_MAX(I,J)
ENDDO
ENDDO
@@ -748,14 +750,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Max Lightning Threat 3
IF((IGET(704)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=LTG3_MAX(I,J)
ENDDO
ENDDO
@@ -769,14 +771,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!--- GSD Updraft Helicity
IF((IGET(727)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=UP_HELI(I,J)
ENDDO
ENDDO
@@ -784,14 +786,14 @@ SUBROUTINE MDL2AGL
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(727))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(727))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Updraft Helicity 1-6 km layer
IF((IGET(701)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=UP_HELI16(I,J)
ENDDO
ENDDO
@@ -799,14 +801,14 @@ SUBROUTINE MDL2AGL
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(701))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(701))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Convective Initiation Lightning
IF((IGET(705)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=NCI_LTG(I,J)/60.0
ENDDO
ENDDO
@@ -820,14 +822,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Convective Activity Lightning
IF((IGET(706)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=NCA_LTG(I,J)/60.0
ENDDO
ENDDO
@@ -841,14 +843,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Convective Initiation Vertical Hydrometeor Flux
IF((IGET(707)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=NCI_WQ(I,J)/60.0
ENDDO
ENDDO
@@ -862,14 +864,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Convective Activity Vertical Hydrometeor Flux
IF((IGET(708)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=NCA_WQ(I,J)/60.0
ENDDO
ENDDO
@@ -883,14 +885,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Convective Initiation Reflectivity
IF((IGET(709)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=NCI_REFD(I,J)/60.0
ENDDO
ENDDO
@@ -904,14 +906,14 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!--- Convective Activity Reflectivity
IF((IGET(710)>0) )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=NCA_REFD(I,J)/60.0
ENDDO
ENDDO
@@ -925,7 +927,7 @@ SUBROUTINE MDL2AGL
fld_info(cfld)%tinvstat = 1
endif
fld_info(cfld)%ntrange = 1
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
!
@@ -949,9 +951,9 @@ SUBROUTINE MDL2AGL
IF(iget1 > 0 .or. iget2 > 0) THEN
!
jj=(jsta+jend)/2
- ii=(im)/2
+ ii=(ista+iend)/2
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
UAGL(I,J) = SPVAL
VAGL(I,J) = SPVAL
!
@@ -1000,13 +1002,13 @@ SUBROUTINE MDL2AGL
END IF
ENDDO
IF(global)then
- ISTART=1
- ISTOP=IM
+ ISTART=ISTA
+ ISTOP=IEND
JSTART=JSTA
JSTOP=JEND
ELSE
- ISTART=2
- ISTOP=IM-1
+ ISTART=ISTA_M
+ ISTOP=IEND_M
JSTART=JSTA_M
JSTOP=JEND_M
END IF
@@ -1018,8 +1020,8 @@ SUBROUTINE MDL2AGL
MINLL=LXXX
! print*,'exchange wind in MDL2AGL from ',MINLL
DO LL=MINLL,LM
- call exch(UH(1:IM,JSTA_2L:JEND_2U,LL))
- call exch(VH(1:IM,JSTA_2L:JEND_2U,LL))
+ call exch(UH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LL))
+ call exch(VH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LL))
END DO
END IF
DO 230 J=JSTART,JSTOP
@@ -1128,7 +1130,7 @@ SUBROUTINE MDL2AGL
!--- Wind Shear (wind speed difference in knots between sfc and 2000 ft)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(ABS(UAGL(I,J)-SPVAL)>SMALL .AND. &
ABS(VAGL(I,J)-SPVAL)>SMALL)THEN
IF(GRIDTYPE=='B' .OR. GRIDTYPE=='E')THEN
@@ -1149,7 +1151,7 @@ SUBROUTINE MDL2AGL
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(259))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(259))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
!
ENDIF ! FOR LEVEL
@@ -1178,9 +1180,9 @@ SUBROUTINE MDL2AGL
!
jj = float(jsta+jend)/2.0
- ii = float(im)/3.0
+ ii = float(ista+iend)/3.0
DO J=JSTA_2L,JEND_2U
- DO I=1,IM
+ DO I=ISTA_2L,IEND_2U
!
PAGL(I,J) = SPVAL
TAGL(I,J) = SPVAL
@@ -1224,7 +1226,7 @@ SUBROUTINE MDL2AGL
!chc J=JHOLD(NN)
! DO 220 J=JSTA,JEND
DO 240 J=JSTA_2L,JEND_2U
- DO 240 I=1,IM
+ DO 240 I=ISTA_2L,IEND_2U
LL = NL1X(I,J)
!---------------------------------------------------------------------
!*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC
@@ -1295,7 +1297,7 @@ SUBROUTINE MDL2AGL
!--- Wind Energy Potential -- 0.5 * moist air density * wind speed^3
IF((IGET(411)>0) ) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(QAGL(I,J)0) ) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=UAGL(I,J)
ENDDO
ENDDO
@@ -1325,13 +1327,13 @@ SUBROUTINE MDL2AGL
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(412))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(412))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!--- V Component of wind
IF((IGET(413)>0) ) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=VAGL(I,J)
ENDDO
ENDDO
@@ -1339,7 +1341,7 @@ SUBROUTINE MDL2AGL
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(413))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(413))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
diff --git a/sorc/ncep_post.fd/MDL2P.f b/sorc/ncep_post.fd/MDL2P.f
index 1b435cd5a..8a023af0e 100644
--- a/sorc/ncep_post.fd/MDL2P.f
+++ b/sorc/ncep_post.fd/MDL2P.f
@@ -1,64 +1,37 @@
!> @file
-! . . .
-!> SUBPROGRAM: MDL2P VERT INTRP OF MODEL LVLS TO PRESSURE
-!! PRGRMMR: BLACK ORG: W/NP22 DATE: 99-09-23
-!!
-!! ABSTRACT:
-!! FOR MOST APPLICATIONS THIS ROUTINE IS THE WORKHORSE OF THE POST PROCESSOR.
-!! IN A NUTSHELL IT INTERPOLATES DATA FROM MODEL TO PRESSURE SURFACES.
-!! IT ORIGINATED FROM THE VERTICAL INTERPOLATION CODE IN THE OLD ETA
-!! POST PROCESSOR SUBROUTINE OUTMAP AND IS A REVISION OF SUBROUTINE ETA2P.
-!!
-!! PROGRAM HISTORY LOG:
-!! 99-09-23 T BLACK - REWRITTEN FROM ETA2P
-!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT
-!! 02-06-12 MIKE BALDWIN - WRF VERSION
-!! 02-07-29 H CHUANG - ADD UNDERGROUND FIELDS AND MEMBRANE SLP FOR WRF
-!! 04-11-24 H CHUANG - ADD FERRIER'S HYDROMETEOR FIELD
-!! 05-07-07 B ZHOU - ADD RSM MODEL for SLP
-!! 05--8-30 B ZHOU - ADD AVIATION PRODUCTS: ICING, CAT, LLWS COMPUTATION
-!! 08-01-01 H CHUANG - ADD GFS D3D FIELDS TO VERTICAL INTERPOLATION
-!! 10-07-01 SMIRNOVA AND HU - ADD RR CHANGES
-!! 10-12-30 H CHUANG - ADD HAINES INDEX TO SUPPORT FIRE WEATHER
-!! 11-02-06 J Wang - ADD grib2 option TO SUPPORT FIRE WEATHER
-!! 12-01-11 S LU - ADD GOCART AEROSOLS
-!! 13-08-01 S Moorthi - some optimization
-!! 14-02-26 S Moorthi - threading datapd assignment
-!! 19-10-30 B CUI - REMOVE "GOTO" STATEMENT
-!! 20-03-25 J MENG - remove grib1
-!! 20-05-20 J MENG - CALRH unification with NAM scheme
-!! 20-11-10 J MENG - USE UPP_PHYSICS MODULE
-!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend)
-!! 21-04-01 J MENG - COMPUTATION ON DEFINED POINTS ONLY
-!!
-!! USAGE: CALL MDL2P
-!! INPUT ARGUMENT LIST:
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! SCLFLD - SCALE ARRAY ELEMENTS BY CONSTANT.
-!! CALPOT - COMPUTE POTENTIAL TEMPERATURE.
-!! CALRH - COMPUTE RELATIVE HUMIDITY.
-!! CALDWP - COMPUTE DEWPOINT TEMPERATURE.
-!! BOUND - BOUND ARRAY ELEMENTS BETWEEN LOWER AND UPPER LIMITS.
-!! CALMCVG - COMPUTE MOISTURE CONVERGENCE.
-!! CALVOR - COMPUTE ABSOLUTE VORTICITY.
-!! CALSTRM - COMPUTE GEOSTROPHIC STREAMFUNCTION.
-!!
-!! LIBRARY:
-!! COMMON - CTLBLK
-!! RQSTFLD
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN 90
-!! MACHINE : IBM SP
-!!
+!> @brief mdl2p() computes vert intrp of model lvls to pressure.
+!>
+!> For most applications this routine is the workhorse of the post processor.
+!> In a nutshell it interpolates data from model to pressure surfaces.
+!> It origiaated from the vertical interpolation code in the old ETA
+!> post processor subroutine outmap() and is a revision of subroutine eta2p().
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1999-09-23 | T Black | Rewritten from eta2p()
+!> 2001-10-25 | H Chuang | Modified to process hybrid model output
+!> 2002-06-12 | Mike Baldwin | WRF Version
+!> 2002-07-29 | H Chuang | Add underground fields and membrane SLP for WRF
+!> 2004-11-24 | H Chuang | Add FERRIER's hydrometeor field
+!> 2005-07-07 | B Zhou | Add RSM model for SLP
+!> 2005--8-30 | B Zhou | Add aviation products: ICING, CAT, LLWS computation
+!> 2008-01-01 | H Chuang | Add GFS D3D fields to vertical interpolation
+!> 2010-07-01 | Smirnova and Hu | Add RR changes
+!> 2010-12-30 | H Chuang | Add Haines index to support fire weather
+!> 2011-02-06 | J Wang | Add grib2 option to support fire weather
+!> 2012-01-11 | S Lu | Add GOCART aerosols
+!> 2013-08-01 | S Moorthi | Some optimization
+!> 2014-02-26 | S Moorthi | Threading datapd assignment
+!> 2019-10-30 | B Cui | Remove "GOTO" statement
+!> 2020-03-25 | J Meng | Remove grib1
+!> 2020-05-20 | J Meng | CALRH unification with NAM scheme
+!> 2020-11-10 | J Meng | Use UPP_PHYSICS module
+!> 2021-03-11 | B Cui | Change local arrays to dimension (im,jsta:jend)
+!> 2021-04-01 | J Meng | Computation on defined points only
+!> 2021-07-07 | J MENG | 2D DECOMPOSITION
+!>
+!> @author T Black W/NP2 @date 1999-09-23
SUBROUTINE MDL2P(iostatusD3D)
!
@@ -84,10 +57,10 @@ SUBROUTINE MDL2P(iostatusD3D)
ALSL, JEND_M, SMFLAG, GRIB, CFLD, FLD_INFO, DATAPD,&
TD3D, IFHR, IFMIN, IM, JM, NBIN_DU, JSTA_2L, &
JEND_2U, LSM, d3d_on, gocart_on, ioform, NBIN_SM, &
- imp_physics
+ imp_physics, ISTA, IEND, ISTA_M, IEND_M, ISTA_2L, IEND_2U
use rqstfld_mod, only: IGET, LVLS, ID, IAVBLFLD, LVLSXML
use gridspec_mod, only: GRIDTYPE, MAPTYPE, DXVAL
- use upp_physics, only: FPVSNEW, CALRH
+ use upp_physics, only: FPVSNEW, CALRH, CALVOR
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
implicit none
@@ -104,7 +77,7 @@ SUBROUTINE MDL2P(iostatusD3D)
real,PARAMETER :: CAPA=0.28589641,P1000=1000.E2
LOGICAL IOOMG,IOALL
real, dimension(im,jm) :: GRID1, GRID2
- real, dimension(im,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL &
+ real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL &
&, Q2SL, WSL, CFRSL, O3SL, TDSL &
&, EGRID1, EGRID2 &
&, FSL_OLD, USL_OLD, VSL_OLD &
@@ -113,8 +86,8 @@ SUBROUTINE MDL2P(iostatusD3D)
REAL, allocatable :: D3DSL(:,:,:), DUSTSL(:,:,:), SMOKESL(:,:,:)
!
integer,intent(in) :: iostatusD3D
- INTEGER, dimension(im,jsta_2l:jend_2u) :: NL1X, NL1XF
- real, dimension(IM,JSTA_2L:JEND_2U,LSM) :: TPRS, QPRS, FPRS
+ INTEGER, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: NL1X, NL1XF
+ real, dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LSM) :: TPRS, QPRS, FPRS
!
INTEGER K, NSMOOTH
!
@@ -128,15 +101,15 @@ SUBROUTINE MDL2P(iostatusD3D)
! QG1 - graupel mixing ratio
! DBZ1 - radar reflectivity
!
- REAL, dimension(im,jsta_2l:jend_2u) :: C1D, QW1, QI1, QR1, QS1, QG1, DBZ1 &
+ REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: C1D, QW1, QI1, QR1, QS1, QG1, DBZ1 &
, FRIME, RAD, HAINES
REAL SDUMMY(IM,2)
! SAVE RH, U,V, for Icing, CAT, LLWS computation
- REAL SAVRH(IM,jsta:jend)
+ REAL SAVRH(ista:iend,jsta:jend)
!jw
- integer I,J,L,LP,LL,LLMH,JJB,JJE,II,JJ,LI,IFINCR,ITD3D,ista,imois,luhi,la
+ integer I,J,L,LP,LL,LLMH,JJB,JJE,II,JJ,LI,IFINCR,ITD3D,istaa,imois,luhi,la
real fact,ALPSL,PSFC,QBLO,PNL1,TBLO,TVRL,TVRBLO,FAC,PSLPIJ, &
ALPTH,AHF,PDV,QL,TVU,TVD,GAMMAS,QSAT,RHL,ZL,TL,PL,ES,part,dum1
logical log1
@@ -146,6 +119,8 @@ SUBROUTINE MDL2P(iostatusD3D)
!
! START MDL2P.
!
+ if(me==0) print*, 'MDL2P SMFLAG=',SMFLAG
+
if (modelname == 'GFS') then
zero = 0.0
else
@@ -239,7 +214,7 @@ SUBROUTINE MDL2P(iostatusD3D)
! print*,'LSM= ',lsm
if(gridtype == 'B' .or. gridtype == 'E') &
- call exch(PINT(1:IM,JSTA_2L:JEND_2U,LP1))
+ call exch(PINT(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LP1))
DO LP=1,LSM
@@ -251,7 +226,7 @@ SUBROUTINE MDL2P(iostatusD3D)
!
!$omp parallel do private(i,j,l)
DO J=JSTA_2L,JEND_2U
- DO I=1,IM
+ DO I=ISTA_2L,IEND_2U
TSL(I,J) = SPVAL
QSL(I,J) = SPVAL
FSL(I,J) = SPVAL
@@ -312,12 +287,12 @@ SUBROUTINE MDL2P(iostatusD3D)
!hc J=JHOLD(NN)
! DO 220 J=JSTA,JEND
- ii = im/2
+ ii = (ista+iend)/2
jj = (jsta+jend)/2
!$omp parallel do private(i,j,k,l,ll,llmh,la,tvd,tvu,fact,fac,ahf,rhl,tl,pl,ql,zl,es,qsat,part,tvrl,tvrblo,tblo,qblo,gammas,pnl1)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
!---------------------------------------------------------------------
!*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC
!*** HUMIDITY, CLOUD WATER/ICE, OMEGA, WINDS, AND TKE.
@@ -785,7 +760,7 @@ SUBROUTINE MDL2P(iostatusD3D)
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
TPRS(I,J,LP) = TSL(I,J)
QPRS(I,J,LP) = QSL(I,J)
FPRS(I,J,LP) = FSL(I,J)
@@ -796,7 +771,8 @@ SUBROUTINE MDL2P(iostatusD3D)
!
IF(gridtype == 'E')THEN
DO J=JSTA,JEND
- DO I=2,IM-MOD(J,2)
+! DO I=2,IM-MOD(J,2)
+ DO I=ISTA_M,IEND-MOD(J,2)
! IF(i == im/2 .and. j == (jsta+jend)/2)then
! do l=1,lm
! print*,'PMIDV=',PMIDV(i,j,l)
@@ -846,13 +822,13 @@ SUBROUTINE MDL2P(iostatusD3D)
!
! IF(NL1X(I,J) == LMP1.AND.PINT(I,J,LMP1) > SPL(LP))THEN
IF(NL1X(I,J) == LP1)THEN
- IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC
+ IF(J == JSTA .AND. I < IEND)THEN !SOUTHERN BC
PDV = 0.5*(PINT(I,J,LP1)+PINT(I+1,J,LP1))
- ELSE IF(J == JM .AND. I < IM)THEN !NORTHERN BC
+ ELSE IF(J == JEND .AND. I < IEND)THEN !NORTHERN BC
PDV = 0.5*(PINT(I,J,LP1)+PINT(I+1,J,LP1))
- ELSE IF(I == 1 .AND. MOD(J,2) == 0) THEN !WESTERN EVEN BC
+ ELSE IF(I == ISTA .AND. MOD(J,2) == 0) THEN !WESTERN EVEN BC
PDV = 0.5*(PINT(I,J-1,LP1)+PINT(I,J+1,LP1))
- ELSE IF(I == IM .AND. MOD(J,2) == 0) THEN !EASTERN EVEN BC
+ ELSE IF(I == IEND .AND. MOD(J,2) == 0) THEN !EASTERN EVEN BC
PDV = 0.5*(PINT(I,J-1,LP1)+PINT(I,J+1,LP1))
ELSE IF (MOD(J,2) < 1) THEN
PDV = 0.25*(PINT(I,J,LP1)+PINT(I-1,J,LP1) &
@@ -870,8 +846,8 @@ SUBROUTINE MDL2P(iostatusD3D)
ENDDO
!
DO J=JSTA,JEND
- DO I=1,IM-MOD(j,2)
-
+! DO I=1,IM-MOD(j,2)
+ DO I=ISTA,IEND-MOD(j,2)
LL = NL1X(I,J)
!---------------------------------------------------------------------
!*** VERTICAL INTERPOLATION OF WINDS FOR A-E GRID
@@ -920,12 +896,13 @@ SUBROUTINE MDL2P(iostatusD3D)
JJE = JEND
IF(MOD(JEND,2) == 0) JJE = JEND-1
DO J=JJB,JJE,2 !chc
- USL(IM,J) = USL(IM-1,J)
- VSL(IM,J) = VSL(IM-1,J)
+ USL(IEND,J) = USL(IEND-1,J)
+ VSL(IEND,J) = VSL(IEND-1,J)
END DO
ELSE IF(gridtype=='B')THEN ! B grid wind interpolation
DO J=JSTA,JEND_m
- DO I=1,IM-1
+! DO I=1,IM-1
+ DO I=ISTA,IEND_m
!*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW
!*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING.
!
@@ -955,8 +932,8 @@ SUBROUTINE MDL2P(iostatusD3D)
ENDDO
!
DO J=JSTA,JEND_m
- DO I=1,IM-1
-
+! DO I=1,IM-1
+ DO I=ISTA,IEND_m
LL = NL1X(I,J)
!---------------------------------------------------------------------
!*** VERTICAL INTERPOLATION OF WINDS FOR A-E GRID
@@ -1013,7 +990,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF(NINT(SPL(LP)) == 50000)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
T500(I,J) = TSL(I,J)
Z500(I,J) = FSL(I,J)*GI
ENDDO
@@ -1026,7 +1003,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF(NINT(SPL(LP)) == 70000)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
T700(I,J) = TSL(I,J)
Z700(I,J) = FSL(I,J)*GI
ENDDO
@@ -1098,7 +1075,7 @@ SUBROUTINE MDL2P(iostatusD3D)
ELSE
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(FSL(I,J) < SPVAL) THEN
GRID1(I,J) = FSL(I,J)*GI
ELSE
@@ -1130,11 +1107,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(012))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(012))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1149,7 +1127,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF(LVLS(LP,IGET(013)) > 0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = TSL(I,J)
ENDDO
ENDDO
@@ -1166,11 +1144,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET(013))
fld_info(cfld)%lvl = LVLSXML(LP,IGET(013))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1183,7 +1162,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF(LVLS(LP,IGET(910))>0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(TSL(I,J) < SPVAL .AND. QSL(I,J) < SPVAL) THEN
GRID1(I,J) = TSL(I,J)*(1.+0.608*QSL(I,J))
ELSE
@@ -1204,11 +1183,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld=cfld+1
fld_info(cfld)%ifld = IAVBLFLD(IGET(910))
fld_info(cfld)%lvl = LVLSXML(LP,IGET(910))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1224,7 +1204,7 @@ SUBROUTINE MDL2P(iostatusD3D)
tem = (P1000/spl(lp)) ** capa
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(TSL(I,J) < SPVAL) THEN
grid1(I,J) = TSL(I,J) * tem
ELSE
@@ -1251,11 +1231,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(014))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(014))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1278,16 +1259,16 @@ SUBROUTINE MDL2P(iostatusD3D)
if ( log1 ) then
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EGRID2(I,J) = SPL(LP)
ENDDO
ENDDO
!
- CALL CALRH(EGRID2(1,jsta),TSL(1,jsta),QSL(1,jsta),EGRID1(1,jsta))
+ CALL CALRH(EGRID2(ista:iend,jsta:jend),TSL(ista:iend,jsta:jend),QSL(ista:iend,jsta:jend),EGRID1(ista:iend,jsta:jend))
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(EGRID1(I,J) < SPVAL) THEN
GRID1(I,J) = EGRID1(I,J)*100.
ELSE
@@ -1307,18 +1288,19 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(017))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(017))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
SAVRH(I,J) = GRID1(I,J)
ENDDO
ENDDO
@@ -1332,7 +1314,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF(LVLS(LP,IGET(331)) > 0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = SPVAL
CFRSL(I,J) = MIN(MAX(0.0,CFRSL(I,J)),1.0)
IF(abs(CFRSL(I,J)-SPVAL) > SMALL) &
@@ -1343,11 +1325,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET(331))
fld_info(cfld)%lvl = LVLSXML(LP,IGET(331))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1360,15 +1343,15 @@ SUBROUTINE MDL2P(iostatusD3D)
IF(LVLS(LP,IGET(015)) > 0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EGRID2(I,J) = SPL(LP)
ENDDO
ENDDO
!
- CALL CALDWP(EGRID2(1,jsta),QSL(1,jsta),EGRID1(1,jsta),TSL(1,jsta))
+ CALL CALDWP(EGRID2(ista:iend,jsta:jend),QSL(ista:iend,jsta:jend),EGRID1(ista:iend,jsta:jend),TSL(ista:iend,jsta:jend))
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(TSL(I,J) < SPVAL) THEN
GRID1(I,J) = EGRID1(I,J)
ELSE
@@ -1380,11 +1363,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(015))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(015))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1397,7 +1381,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF(LVLS(LP,IGET(016)) > 0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = QSL(I,J)
ENDDO
ENDDO
@@ -1406,11 +1390,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(016))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(016))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1423,7 +1408,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF(LVLS(LP,IGET(020)) > 0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = OSL(I,J)
ENDDO
ENDDO
@@ -1449,11 +1434,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(020))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(020))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1466,7 +1452,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF(LVLS(LP,IGET(284)) > 0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = WSL(I,J)
ENDDO
ENDDO
@@ -1474,11 +1460,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(284))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(284))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1489,28 +1476,29 @@ SUBROUTINE MDL2P(iostatusD3D)
!
IF(IGET(085) > 0)THEN
IF(LVLS(LP,IGET(085)) > 0)THEN
- CALL CALMCVG(QSL(1,jsta_2l),USL(1,jsta_2l),VSL(1,jsta_2l),EGRID1(1,jsta_2l))
+ CALL CALMCVG(QSL(ista_2l,jsta_2l),USL(ista_2l,jsta_2l),VSL(ista_2l,jsta_2l),EGRID1(ista_2l,jsta_2l))
! if(me == 0) print *,'after calmcvgme=',me,'USL=',USL(1:10,JSTA)
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = EGRID1(I,J)
ENDDO
ENDDO
!MEB NOT SURE IF I STILL NEED THIS
! CONVERT TO DIVERGENCE FOR GRIB UNITS
!
-! CALL SCLFLD(GRID1,-1.0,IM,JM)
+! CALL SCLFLD(GRID1(ista:iend,jsta:jend),-1.0,IM,JM)
!MEB NOT SURE IF I STILL NEED THIS
if(grib == 'grib2')then
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(085))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(085))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
! if(me==0) print *,'in mdl2p,mconv, lp=',fld_info(cfld)%lvl,'lp=',lp
@@ -1531,7 +1519,7 @@ SUBROUTINE MDL2P(iostatusD3D)
if ( log1 ) then
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = USL(I,J)
GRID2(I,J) = VSL(I,J)
ENDDO
@@ -1554,22 +1542,24 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(018))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(018))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(019))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(019))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -1584,7 +1574,7 @@ SUBROUTINE MDL2P(iostatusD3D)
! print *,'me=',me,'EGRID1=',EGRID1(1:10,JSTA)
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = EGRID1(I,J)
ENDDO
ENDDO
@@ -1610,11 +1600,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(021))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(021))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1626,16 +1617,16 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(086)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(FSL(I,J) 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = Q2SL(I,J)
ENDDO
ENDDO
@@ -1672,11 +1664,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(022))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(022))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1691,7 +1684,7 @@ SUBROUTINE MDL2P(iostatusD3D)
! GFS does not seperate cloud water from ice, hoping to do that in Feb 08 implementation
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(QW1(I,J) < SPVAL .AND. QI1(I,J) < SPVAL) THEN
GRID1(I,J) = QW1(I,J) + QI1(I,J)
QI1(I,J) = spval
@@ -1703,7 +1696,7 @@ SUBROUTINE MDL2P(iostatusD3D)
ELSE
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = QW1(I,J)
ENDDO
ENDDO
@@ -1712,11 +1705,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(153))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(153))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1729,7 +1723,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(166)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = QI1(I,J)
ENDDO
ENDDO
@@ -1737,11 +1731,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(166))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(166))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1753,7 +1748,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(183)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = QR1(I,J)
ENDDO
ENDDO
@@ -1761,11 +1756,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(183))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(183))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1777,7 +1773,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(184)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = QS1(I,J)
ENDDO
ENDDO
@@ -1785,11 +1781,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(184))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(184))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1801,7 +1798,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(416)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = QG1(I,J)
ENDDO
ENDDO
@@ -1809,11 +1806,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(416))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(416))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1826,7 +1824,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(198)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = C1D(I,J)
ENDDO
ENDDO
@@ -1834,11 +1832,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(198))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(198))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1850,7 +1849,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(263)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = FRIME(I,J)
ENDDO
ENDDO
@@ -1858,11 +1857,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(263))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(263))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1874,7 +1874,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(294)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RAD(I,J)
ENDDO
ENDDO
@@ -1882,11 +1882,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(294))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(294))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1898,7 +1899,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(251)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = DBZ1(I,J)
ENDDO
ENDDO
@@ -1906,11 +1907,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(251))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(251))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1920,11 +1922,11 @@ SUBROUTINE MDL2P(iostatusD3D)
!--- IN-FLIGHT ICING CONDITION: ADD BY B. ZHOU
IF(IGET(257) > 0)THEN
IF(LVLS(LP,IGET(257)) > 0)THEN
- CALL CALICING(TSL(1,jsta), SAVRH, OSL(1,jsta), EGRID1(1,jsta))
+ CALL CALICING(TSL(ista:iend,jsta:jend), SAVRH, OSL(ista:iend,jsta:jend), EGRID1(ista:iend,jsta:jend))
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = EGRID1(I,J)
ENDDO
ENDDO
@@ -1932,11 +1934,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(257))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(257))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1951,7 +1954,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF(LVLS(LP,IGET(258)) > 0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(FSL(I,J) 3. .OR. GRID1(I,J) < 0.)
! + print*,'bad CAT',i,j,GRID1(I,J)
@@ -1975,11 +1978,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(258))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(258))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1990,7 +1994,7 @@ SUBROUTINE MDL2P(iostatusD3D)
!$omp parallel do private(i,j)
DO J=JSTA_2L,JEND_2U
- DO I=1,IM
+ DO I=ISTA_2L,IEND_2U
USL_OLD(I,J) = USL(I,J)
VSL_OLD(I,J) = VSL(I,J)
IF(FSL(I,J) 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = O3SL(I,J)
ENDDO
ENDDO
@@ -2016,11 +2020,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(268))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(268))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2032,7 +2037,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(738)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(SMOKESL(I,J,1) 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = DUSTSL(I,J,1)
ENDDO
ENDDO
@@ -2068,11 +2074,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(438))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(438))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2083,7 +2090,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(439)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = DUSTSL(I,J,2)
ENDDO
ENDDO
@@ -2091,11 +2098,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(439))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(439))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2106,7 +2114,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(440)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = DUSTSL(I,J,3)
ENDDO
ENDDO
@@ -2114,11 +2122,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(440))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(440))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2129,7 +2138,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(441)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = DUSTSL(I,J,4)
ENDDO
ENDDO
@@ -2137,11 +2146,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(441))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(441))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2152,7 +2162,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(442)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = DUSTSL(I,J,5)
ENDDO
ENDDO
@@ -2160,11 +2170,12 @@ SUBROUTINE MDL2P(iostatusD3D)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(442))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(442))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2179,7 +2190,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(355)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,1)
ENDDO
ENDDO
@@ -2211,11 +2222,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2226,7 +2238,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(354)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,2)
ENDDO
ENDDO
@@ -2258,11 +2270,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2273,7 +2286,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(356)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,3)
ENDDO
ENDDO
@@ -2305,11 +2318,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2320,7 +2334,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(357)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,4)
ENDDO
ENDDO
@@ -2352,11 +2366,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2367,7 +2382,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(358)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,5)
ENDDO
ENDDO
@@ -2399,11 +2414,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2414,7 +2430,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(359)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,6)
ENDDO
ENDDO
@@ -2446,11 +2462,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2461,7 +2478,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(360)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,7)
ENDDO
ENDDO
@@ -2493,11 +2510,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2508,7 +2526,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(361)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,8)
ENDDO
ENDDO
@@ -2540,11 +2558,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2555,7 +2574,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(362)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,9)
ENDDO
ENDDO
@@ -2587,11 +2606,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2602,7 +2622,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(363)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,10)
ENDDO
ENDDO
@@ -2635,11 +2655,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2650,7 +2671,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(364)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,11)
ENDDO
ENDDO
@@ -2683,11 +2704,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2698,7 +2720,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(365)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,12)
ENDDO
ENDDO
@@ -2731,11 +2753,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2746,7 +2769,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(366)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,13)
ENDDO
ENDDO
@@ -2779,11 +2802,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2794,7 +2818,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(367)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,14)
ENDDO
ENDDO
@@ -2827,11 +2851,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2842,7 +2867,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(368)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,15)
ENDDO
ENDDO
@@ -2875,11 +2900,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2890,7 +2916,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(369)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,16)
ENDDO
ENDDO
@@ -2922,11 +2948,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2937,7 +2964,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(370)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,17)
ENDDO
ENDDO
@@ -2970,11 +2997,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2985,7 +3013,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(371)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,18)
ENDDO
ENDDO
@@ -3018,11 +3046,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3033,7 +3062,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(372)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,19)
ENDDO
ENDDO
@@ -3065,11 +3094,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3080,7 +3110,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(373)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,20)
ENDDO
ENDDO
@@ -3113,11 +3143,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3128,7 +3159,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(374)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,21)
ENDDO
ENDDO
@@ -3161,11 +3192,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3176,7 +3208,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(375)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,22)
ENDDO
ENDDO
@@ -3208,11 +3240,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3223,7 +3256,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(379)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(D3DSL(i,j,1)/=SPVAL)THEN
GRID1(I,J) = D3DSL(i,j,1) + D3DSL(i,j,2) &
+ D3DSL(i,j,3) + D3DSL(i,j,4) &
@@ -3261,11 +3294,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3276,7 +3310,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(391)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,23)
ENDDO
ENDDO
@@ -3309,11 +3343,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3324,7 +3359,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(392)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,24)
ENDDO
ENDDO
@@ -3357,11 +3392,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3372,7 +3408,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(393)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,25)
ENDDO
ENDDO
@@ -3405,11 +3441,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3420,7 +3457,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(394)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,26)
ENDDO
ENDDO
@@ -3453,11 +3490,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3468,7 +3506,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IF (LVLS(LP,IGET(395)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = D3DSL(i,j,27)
ENDDO
ENDDO
@@ -3501,11 +3539,12 @@ SUBROUTINE MDL2P(iostatusD3D)
fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D
endif
fld_info(cfld)%tinvstat=ITD3D
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3515,7 +3554,7 @@ SUBROUTINE MDL2P(iostatusD3D)
! CHUANG: COMPUTE HAINES INDEX
IF (IGET(455) > 0) THEN
- ii=im/2+100
+ ii=(ista+iend)/2+100
jj=(jsta+jend)/2-100
IF(ABS(SPL(LP)-50000.) 17. .AND. DUM1 <= 21.) THEN
- ISTA = 2
+ ISTAA = 2
ELSE
- ISTA = 3
+ ISTAA = 3
END IF
DUM1 = TSL(I,J)-TDSL(I,J)
IF(DUM1 <= 14.) THEN
@@ -3551,7 +3590,7 @@ SUBROUTINE MDL2P(iostatusD3D)
IMOIS = 3
END IF
IF(TSL(I,J) 5. .AND. DUM1 <= 10.) THEN
- ISTA = 2
+ ISTAA = 2
ELSE
- ISTA = 3
+ ISTAA = 3
END IF
DUM1 = TSL(I,J)-TDSL(I,J)
IF(DUM1 <= 5.) THEN
@@ -3597,7 +3636,7 @@ SUBROUTINE MDL2P(iostatusD3D)
! if(i==570 .and. j==574)print*,'mid haines index:',i,j,luhi,tsl(i,j) &
! ,tprs(i,j,luhi),tdsl(i,j),ista,imois,spl(luhi),spl(lp),haines(i,j)
IF(TSL(I,J) 3. .AND. DUM1 <=7. ) THEN
- ISTA = 2
+ ISTAA = 2
ELSE
- ISTA = 3
+ ISTAA = 3
END IF
DUM1 = TSL(I,J)-TDSL(I,J)
IF(DUM1 <=5. ) THEN
@@ -3641,7 +3680,7 @@ SUBROUTINE MDL2P(iostatusD3D)
! if(i==570 .and. j==574)print*,'low haines index:',i,j,luhi,tsl(i,j) &
! ,tprs(i,j,luhi),tdsl(i,j),ista,imois,spl(luhi),spl(lp),haines(i,j)
IF(TSL(I,J) WONT DERIVE MESINGER SLP'
END IF
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = PSLP(I,J)
ENDDO
ENDDO
@@ -3795,11 +3838,12 @@ SUBROUTINE MDL2P(iostatusD3D)
if(grib == 'grib2')then
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET(023))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3811,18 +3855,19 @@ SUBROUTINE MDL2P(iostatusD3D)
CALL MAPSSLP(TPRS)
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = PSLP(I,J)
ENDDO
ENDDO
if(grib == 'grib2') then
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET(445))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3843,7 +3888,7 @@ SUBROUTINE MDL2P(iostatusD3D)
! because MOS can't adjust to the much lower H
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(FSL(I,J)0) THEN
!$omp parallel do
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(FSL1(I,J)0) THEN
!$omp parallel do
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=AKH(I,J)
ENDDO
ENDDO
if(grib=="grib2" )then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(243))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
if(me==0)print*,'output Heat Diffusivity'
@@ -353,7 +354,7 @@ SUBROUTINE MDL2SIGMA
NHOLD=0
!
DO J=JSTA_2L,JEND_2U
- DO I=1,IM
+ DO I=ISTA_2L,IEND_2U
!
TSL(I,J)=SPVAL
@@ -407,7 +408,7 @@ SUBROUTINE MDL2SIGMA
!hc J=JHOLD(NN)
DO 220 J=JSTA,JEND ! Moorthi on Nov 26 2014
! DO 220 J=JSTA_2L,JEND_2U
- DO 220 I=1,IM
+ DO 220 I=ISTA,IEND
LL=NL1X(I,J)
!---------------------------------------------------------------------
!*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC
@@ -555,7 +556,7 @@ SUBROUTINE MDL2SIGMA
!
! OBTAIN GEOPOTENTIAL AND KH ON INTERFACES
DO J=JSTA_2L,JEND_2U
- DO I=1,IM
+ DO I=ISTA_2L,IEND_2U
FSL(I,J)=SPVAL
AKH(I,J)=SPVAL
NL1XF(I,J)=LP1
@@ -571,7 +572,7 @@ SUBROUTINE MDL2SIGMA
!
! DO J=JSTA_2L,JEND_2U
DO J=JSTA,JEND ! Moorthi on 26 Nov 2014
- DO I=1,IM
+ DO I=ISTA,IEND
DONEFSL1=.FALSE.
TSLDONE=.FALSE.
LLMH = NINT(LMH(I,J))
@@ -721,22 +722,41 @@ SUBROUTINE MDL2SIGMA
! VERTICAL INTERPOLATION FOR WIND FOR E and B GRIDS
!
if(gridtype=='B' .or. gridtype=='E') &
- call exch(PINT(1:IM,JSTA_2L:JEND_2U,LP1))
+ call exch(PINT(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LP1))
IF(gridtype=='E')THEN
DO J=JSTA,JEND
- DO I=1,IM-MOD(J,2)
+! DO I=1,IM-MOD(J,2)
+ DO I=ISTA,IEND-MOD(J,2) !Jesse 20211014
!
!*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW
!*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING.
!
LLMH = NINT(LMH(I,J))
- IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC
+
+!Jesse 20211014
+! IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC
+! PDV=0.5*(PINT(I,J,LLMH+1)+PINT(I+1,J,LLMH+1))
+! ELSE IF(J==JM .AND. I0)THEN
!$omp parallel do
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(FSL(I,J)0) THEN
!$omp parallel do
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=AKH(I,J)
IF(LP==(LSIG+1))GRID1(I,J)=0.0 !! NO SLIP ASSUMTION FOR CMAQ
ENDDO
@@ -962,7 +1004,7 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(243))
fld_info(cfld)%lvl=LVLSXML(LP+1,IGET(243))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
if(me==0)print*,'output Heat Diffusivity'
ENDIF
@@ -973,7 +1015,7 @@ SUBROUTINE MDL2SIGMA
IF(IGET(206)>0) THEN
IF(LVLS(LP,IGET(206))>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=TSL(I,J)
ENDDO
ENDDO
@@ -981,7 +1023,7 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(206))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(206))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -992,7 +1034,7 @@ SUBROUTINE MDL2SIGMA
IF(LVLS(LP,IGET(216))>0)THEN
!$omp parallel do
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
LLMH = NINT(LMH(I,J))
GRID1(I,J)=PTSIGO+ASIGO(LP)*(PINT(I,J,LLMH+1)-PTSIGO)
ENDDO
@@ -1001,7 +1043,7 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(216))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(216))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1011,7 +1053,7 @@ SUBROUTINE MDL2SIGMA
IF(IGET(207)>0)THEN
IF(LVLS(LP,IGET(207))>0)THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=QSL(I,J)
ENDDO
ENDDO
@@ -1020,7 +1062,7 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(207))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(207))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1030,7 +1072,7 @@ SUBROUTINE MDL2SIGMA
IF(IGET(210)>0)THEN
IF(LVLS(LP,IGET(210))>0)THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=OSL(I,J)
ENDDO
ENDDO
@@ -1038,7 +1080,7 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(210))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(210))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1048,7 +1090,7 @@ SUBROUTINE MDL2SIGMA
IF(IGET(208)>0.OR.IGET(209)>0)THEN
IF(LVLS(LP,IGET(208))>0.OR.LVLS(LP,IGET(209))>0) then
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=USL(I,J)
GRID2(I,J)=VSL(I,J)
ENDDO
@@ -1057,11 +1099,11 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(208))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(208))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(209))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(209))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID2(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1071,7 +1113,7 @@ SUBROUTINE MDL2SIGMA
IF (IGET(217)>0) THEN
IF (LVLS(LP,IGET(217))>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=Q2SL(I,J)
ENDDO
ENDDO
@@ -1079,7 +1121,7 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(217))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(217))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1089,7 +1131,7 @@ SUBROUTINE MDL2SIGMA
IF (IGET(211)>0) THEN
IF (LVLS(LP,IGET(211))>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=QW1(I,J)
ENDDO
ENDDO
@@ -1097,7 +1139,7 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(211))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(211))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1107,7 +1149,7 @@ SUBROUTINE MDL2SIGMA
IF (IGET(212)>0) THEN
IF (LVLS(LP,IGET(212))>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=QI1(I,J)
ENDDO
ENDDO
@@ -1115,7 +1157,7 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(212))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(212))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1124,7 +1166,7 @@ SUBROUTINE MDL2SIGMA
IF (IGET(213)>0) THEN
IF (LVLS(LP,IGET(213))>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=QR1(I,J)
ENDDO
ENDDO
@@ -1132,7 +1174,7 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(213))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(213))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1141,7 +1183,7 @@ SUBROUTINE MDL2SIGMA
IF (IGET(214)>0) THEN
IF (LVLS(LP,IGET(214))>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=QS1(I,J)
ENDDO
ENDDO
@@ -1149,7 +1191,7 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(214))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(214))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1158,7 +1200,7 @@ SUBROUTINE MDL2SIGMA
IF (IGET(255)>0) THEN
IF (LVLS(LP,IGET(255))>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=QG1(I,J)
ENDDO
ENDDO
@@ -1166,7 +1208,7 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(255))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(255))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1175,7 +1217,7 @@ SUBROUTINE MDL2SIGMA
IF (IGET(215)>0) THEN
IF (LVLS(LP,IGET(215))>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=C1D(I,J)
ENDDO
ENDDO
@@ -1183,7 +1225,7 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(215))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(215))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1192,7 +1234,7 @@ SUBROUTINE MDL2SIGMA
IF (IGET(222)>0) THEN
IF (LVLS(LP,IGET(222))>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=CFRSIG(I,J)
ENDDO
ENDDO
@@ -1200,7 +1242,7 @@ SUBROUTINE MDL2SIGMA
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(222))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(222))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
diff --git a/sorc/ncep_post.fd/MDL2SIGMA2.f b/sorc/ncep_post.fd/MDL2SIGMA2.f
index 1efa8da73..a02107e10 100644
--- a/sorc/ncep_post.fd/MDL2SIGMA2.f
+++ b/sorc/ncep_post.fd/MDL2SIGMA2.f
@@ -20,6 +20,7 @@
!! 20-03-25 J MENG - remove grib1
!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend)
!! 21-07-26 W Meng - Restrict compuatation from undefined grids
+!! 21-10-14 J MENG - 2D DECOMPOSITION
!!
!! USAGE: CALL MDL2P
!! INPUT ARGUMENT LIST:
@@ -50,7 +51,8 @@ SUBROUTINE MDL2SIGMA2
use masks, only: lmh
use params_mod, only: pq0, a2, a3, a4, rgamog
use ctlblk_mod, only: pt, jsta_2l, jend_2u, spval, lp1, lm, jsta, jend,&
- grib, cfld, datapd, fld_info, im, jm, im_jm
+ grib, cfld, datapd, fld_info, im, jm, im_jm, &
+ ista, iend, ista_2l, iend_2u
use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml
!
implicit none
@@ -61,12 +63,12 @@ SUBROUTINE MDL2SIGMA2
!
LOGICAL READTHK
! REAL,dimension(im,jm) :: FSL, TSL, QSL, osl, usl, vsl, q2sl, fsl1, &
- REAL,dimension(im,jsta_2l:jend_2u) :: TSL
- REAL,dimension(im,jsta_2l:jend_2u) :: grid1
+ REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: TSL
+ REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: grid1
REAL SIGO(LSIG+1),DSIGO(LSIG),ASIGO(LSIG)
!
! INTEGER,dimension(im,jm) :: IHOLD,JHOLD,NL1X,NL1XF
- INTEGER,dimension(im,jsta_2l:jend_2u) :: NL1X
+ INTEGER,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: NL1X
!
!
!--- Definition of the following 2D (horizontal) dummy variables
@@ -134,7 +136,7 @@ SUBROUTINE MDL2SIGMA2
NHOLD=0
!
DO J=JSTA_2L,JEND_2U
- DO I=1,IM
+ DO I=ISTA_2L,IEND_2U
!
TSL(I,J)=SPVAL
@@ -175,7 +177,7 @@ SUBROUTINE MDL2SIGMA2
! DO 220 J=JSTA,JEND
! DO 220 J=JSTA_2L,JEND_2U
DO 220 J=JSTA,JEND ! Moorthi on Nov 26, 2014
- DO 220 I=1,IM
+ DO 220 I=ISTA,IEND
LL=NL1X(I,J)
!---------------------------------------------------------------------
!*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC
@@ -264,7 +266,7 @@ SUBROUTINE MDL2SIGMA2
IF(IGET(296)>0) THEN
IF(LVLS(LP,IGET(296))>0)THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=TSL(I,J)
ENDDO
ENDDO
@@ -272,7 +274,7 @@ SUBROUTINE MDL2SIGMA2
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(296))
fld_info(cfld)%lvl=LVLSXML(LP,IGET(296))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
diff --git a/sorc/ncep_post.fd/MDL2STD_P.f b/sorc/ncep_post.fd/MDL2STD_P.f
index bcb81f375..ee5ff8a94 100644
--- a/sorc/ncep_post.fd/MDL2STD_P.f
+++ b/sorc/ncep_post.fd/MDL2STD_P.f
@@ -1,40 +1,19 @@
!> @file
-! . . .
-!> SUBPROGRAM: MDL2STD_P VERT INTRP OF MODEL LVLS TO STANDARD ATMOSPEHRIC PRESSURE
-!! PRGRMMR: Y Mao ORG: W/NP22 DATE: Sep 2019
-!!
-!! ABSTRACT:
-!! ORIGINATED FROM MISCLN.f. THIS ROUTINE INTERPOLATE TO STANDARD
-!! ATMOSPHERIC PRESSURE, INSTEAD OF MODEL PRESSURE
-!!
-!! PROGRAM HISTORY LOG:
-!! 19-09-24 Y Mao - REWRITTEN FROM MISCLN.f
-!! 20-05-20 J MENG - CALRH unification with NAM scheme
-!! 20-11-10 J MENG - USE UPP_PHYSICS MODULE
-!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend)
-!!
-!! USAGE: CALL MDL2STD_P
-!! INPUT ARGUMENT LIST:
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! FDLVL_UV - COMPUTE FD LEVEL WIND (AGL OR MSL).
-!! FDLVL_MASS - COMPUTE FD LEVEL MASS (AGL OR MSL).
-!!
-!! LIBRARY:
-!! COMMON - CTLBLK
-!! RQSTFLD
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN 90
-!! MACHINE : IBM SP
-!!
+!> @brief mdl2std_p() vert intrp of model lvls to standard atmospheric pressure.
+!>
+!> Originated from MISCLN.f. This routine interpolate to standard
+!> atmospheric pressure, instead of model pressure.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2019-09-24 | Y Mao | Rewritten from MISCLN.f
+!> 2020-05-20 | J Meng | CALRH unification with NAM scheme
+!> 2020-11-10 | J Meng | Use UPP_PHYSICS Module
+!> 2021-03-11 | B Cui | Change local arrays to dimension (im,jsta:jend)
+!> 2021-10-14 | J MENG | 2D DECOMPOSITION
+!>
+!> @author Y Mao W/NP22 @date 2019-09-24
SUBROUTINE MDL2STD_P()
!
@@ -44,10 +23,11 @@ SUBROUTINE MDL2STD_P()
use vrbls3d, only: ICING_GFIP, ICING_GFIS, catedr, mwt, gtg
use ctlblk_mod, only: grib, cfld, fld_info, datapd, im, jsta, jend, jm, &
lm, htfd, spval, nfd, me,&
- jsta_2l, jend_2u, MODELNAME
+ jsta_2l, jend_2u, MODELNAME,&
+ ista, iend, ista_2l, iend_2u
use rqstfld_mod, only: iget, lvls, iavblfld, lvlsxml
use grib2_module, only: pset
- use upp_physics, only: CALRH
+ use upp_physics, only: CALRH, CALVOR
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
@@ -55,11 +35,11 @@ SUBROUTINE MDL2STD_P()
real, external :: P2H, relabel
- real,dimension(im,jsta_2l:jend_2u) :: grid1
- real,dimension(im,jsta_2l:jend_2u) :: EGRID1,EGRID2,EGRID3,EGRID4
+ real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: grid1
+ real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: EGRID1,EGRID2,EGRID3,EGRID4
!
- integer I,J,jj,L,ITYPE,IFD,ITYPEFDLVL(NFD)
+ integer I,J,ii,jj,L,ITYPE,IFD,ITYPEFDLVL(NFD)
! Variables introduced to allow FD levels from control file - Y Mao
integer :: N,NFDCTL
@@ -119,8 +99,8 @@ SUBROUTINE MDL2STD_P()
ENDDO
if(allocated(VAR3D1)) deallocate(VAR3D1)
if(allocated(VAR3D2)) deallocate(VAR3D2)
- allocate(VAR3D1(IM,JSTA_2L:JEND_2U,NFDCTL))
- allocate(VAR3D2(IM,JSTA_2L:JEND_2U,NFDCTL))
+ allocate(VAR3D1(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NFDCTL))
+ allocate(VAR3D2(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NFDCTL))
VAR3D1=SPVAL
VAR3D2=SPVAL
@@ -131,7 +111,7 @@ SUBROUTINE MDL2STD_P()
IF (LVLS(IFD,IGET(520)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=VAR3D1(I,J,IFD)
ENDDO
ENDDO
@@ -139,11 +119,12 @@ SUBROUTINE MDL2STD_P()
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(520))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(520))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -152,7 +133,7 @@ SUBROUTINE MDL2STD_P()
IF (LVLS(IFD,IGET(521)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=VAR3D2(I,J,IFD)
ENDDO
ENDDO
@@ -160,23 +141,24 @@ SUBROUTINE MDL2STD_P()
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(521))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(521))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
ENDIF
! ABSV
IF (LVLS(IFD,IGET(524)) > 0) THEN
- EGRID1=VAR3D1(1:IM,JSTA_2L:JEND_2U,IFD)
- EGRID2=VAR3D2(1:IM,JSTA_2L:JEND_2U,IFD)
+ EGRID1=VAR3D1(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,IFD)
+ EGRID2=VAR3D2(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,IFD)
call CALVOR(EGRID1,EGRID2,EGRID3)
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=EGRID3(I,J)
ENDDO
ENDDO
@@ -184,11 +166,12 @@ SUBROUTINE MDL2STD_P()
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(524))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(524))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -206,7 +189,7 @@ SUBROUTINE MDL2STD_P()
if(allocated(QIN)) deallocate(QIN)
if(allocated(QTYPE)) deallocate(QTYPE)
- ALLOCATE(QIN(IM,JSTA:JEND,LM,NFDMAX))
+ ALLOCATE(QIN(ISTA:IEND,JSTA:JEND,LM,NFDMAX))
ALLOCATE(QTYPE(NFDMAX))
! INITIALIZE INPUTS
@@ -214,53 +197,53 @@ SUBROUTINE MDL2STD_P()
IF(IGET(450) > 0) THEN
nFDS = nFDS + 1
IDS(nFDS) = 450
- QIN(1:IM,JSTA:JEND,1:LM,nFDS)=icing_gfip(1:IM,JSTA:JEND,1:LM)
+ QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=icing_gfip(ISTA:IEND,JSTA:JEND,1:LM)
QTYPE(nFDS)="O"
end if
IF(IGET(480) > 0) THEN
nFDS = nFDS + 1
IDS(nFDS) = 480
- QIN(1:IM,JSTA:JEND,1:LM,nFDS)=icing_gfis(1:IM,JSTA:JEND,1:LM)
+ QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=icing_gfis(ISTA:IEND,JSTA:JEND,1:LM)
QTYPE(nFDS)="O"
end if
IF(IGET(464) > 0) THEN
nFDS = nFDS + 1
IDS(nFDS) = 464
- QIN(1:IM,JSTA:JEND,1:LM,nFDS)=gtg(1:IM,JSTA:JEND,1:LM)
+ QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=gtg(ISTA:IEND,JSTA:JEND,1:LM)
QTYPE(nFDS)="O"
end if
IF(IGET(465) > 0) THEN
nFDS = nFDS + 1
IDS(nFDS) = 465
- QIN(1:IM,JSTA:JEND,1:LM,nFDS)=catedr(1:IM,JSTA:JEND,1:LM)
+ QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=catedr(ISTA:IEND,JSTA:JEND,1:LM)
QTYPE(nFDS)="O"
end if
IF(IGET(466) > 0) THEN
nFDS = nFDS + 1
IDS(nFDS) = 466
- QIN(1:IM,JSTA:JEND,1:LM,nFDS)=mwt(1:IM,JSTA:JEND,1:LM)
+ QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=mwt(ISTA:IEND,JSTA:JEND,1:LM)
QTYPE(nFDS)="O"
end if
IF(IGET(519) > 0) THEN
nFDS = nFDS + 1
IDS(nFDS) = 519
- QIN(1:IM,JSTA:JEND,1:LM,nFDS)=T(1:IM,JSTA:JEND,1:LM)
+ QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=T(ISTA:IEND,JSTA:JEND,1:LM)
QTYPE(nFDS)="T"
end if
IF(IGET(523) > 0) THEN
nFDS = nFDS + 1
IDS(nFDS) = 523
- QIN(1:IM,JSTA:JEND,1:LM,nFDS)=OMGA(1:IM,JSTA:JEND,1:LM)
+ QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=OMGA(ISTA:IEND,JSTA:JEND,1:LM)
QTYPE(nFDS)="W"
end if
IF(IGET(525) > 0) THEN
nFDS = nFDS + 1
IDS(nFDS) = 525
- QIN(1:IM,JSTA:JEND,1:LM,nFDS)=QQW(1:IM,JSTA:JEND,1:LM)+ &
- QQR(1:IM,JSTA:JEND,1:LM)+ &
- QQS(1:IM,JSTA:JEND,1:LM)+ &
- QQG(1:IM,JSTA:JEND,1:LM)+ &
- QQI(1:IM,JSTA:JEND,1:LM)
+ QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=QQW(ISTA:IEND,JSTA:JEND,1:LM)+ &
+ QQR(ISTA:IEND,JSTA:JEND,1:LM)+ &
+ QQS(ISTA:IEND,JSTA:JEND,1:LM)+ &
+ QQG(ISTA:IEND,JSTA:JEND,1:LM)+ &
+ QQI(ISTA:IEND,JSTA:JEND,1:LM)
QTYPE(nFDS)="C"
end if
@@ -281,7 +264,7 @@ SUBROUTINE MDL2STD_P()
ENDDO
if(allocated(QFD)) deallocate(QFD)
- ALLOCATE(QFD(IM,JSTA:JEND,NFDCTL,nFDS))
+ ALLOCATE(QFD(ISTA:IEND,JSTA:JEND,NFDCTL,nFDS))
QFD=SPVAL
call FDLVL_MASS(ITYPEFDLVLCTL,NFDCTL,pset%param(N)%level,HTFDCTL,nFDS,QIN,QTYPE,QFD)
@@ -296,7 +279,7 @@ SUBROUTINE MDL2STD_P()
N1=N
DO IFD = 1,NFDCTL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(QFD(I,J,IFD,N) < SPVAL) then
QFD(I,J,IFD,N)=max(0.0,QFD(I,J,IFD,N))
QFD(I,J,IFD,N)=min(1.0,QFD(I,J,IFD,N))
@@ -311,7 +294,7 @@ SUBROUTINE MDL2STD_P()
N1=N
DO IFD = 1,NFDCTL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(QFD(I,J,IFD,N) < SPVAL) then
QFD(I,J,IFD,N)=max(0.0,QFD(I,J,IFD,N))
endif
@@ -330,7 +313,7 @@ SUBROUTINE MDL2STD_P()
if(iID==480) then
DO IFD = 1,NFDCTL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(N1 > 0) then
! Icing severity is 0 when icing potential is too small
if(QFD(I,J,IFD,N1) < 0.001) QFD(I,J,IFD,N)=0.
@@ -356,7 +339,7 @@ SUBROUTINE MDL2STD_P()
if(iID==464 .or. iID==465 .or. iID==466) then
DO IFD = 1,NFDCTL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(QFD(I,J,IFD,N) < SPVAL) then
QFD(I,J,IFD,N)=max(0.0,QFD(I,J,IFD,N))
QFD(I,J,IFD,N)=min(1.0,QFD(I,J,IFD,N))
@@ -375,7 +358,7 @@ SUBROUTINE MDL2STD_P()
IF (LVLS(IFD,IGET(iID)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=QFD(I,J,IFD,N)
ENDDO
ENDDO
@@ -383,11 +366,12 @@ SUBROUTINE MDL2STD_P()
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(iID))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(iID))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -417,7 +401,7 @@ SUBROUTINE MDL2STD_P()
IF (LVLS(IFD,IGET(iID)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=HTFDCTL(IFD)
ENDDO
ENDDO
@@ -425,11 +409,12 @@ SUBROUTINE MDL2STD_P()
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(iID))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(iID))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -456,15 +441,15 @@ SUBROUTINE MDL2STD_P()
if(allocated(QIN)) deallocate(QIN)
if(allocated(QTYPE)) deallocate(QTYPE)
- ALLOCATE(QIN(IM,JSTA:JEND,LM,2))
+ ALLOCATE(QIN(ISTA:IEND,JSTA:JEND,LM,2))
ALLOCATE(QTYPE(2))
- QIN(1:IM,JSTA:JEND,1:LM,1)=T(1:IM,JSTA:JEND,1:LM)
- QIN(1:IM,JSTA:JEND,1:LM,2)=Q(1:IM,JSTA:JEND,1:LM)
+ QIN(ISTA:IEND,JSTA:JEND,1:LM,1)=T(ISTA:IEND,JSTA:JEND,1:LM)
+ QIN(ISTA:IEND,JSTA:JEND,1:LM,2)=Q(ISTA:IEND,JSTA:JEND,1:LM)
QTYPE(1)="T"
QTYPE(2)="Q"
if(allocated(QFD)) deallocate(QFD)
- ALLOCATE(QFD(IM,JSTA:JEND,NFDCTL,2))
+ ALLOCATE(QFD(ISTA:IEND,JSTA:JEND,NFDCTL,2))
QFD=SPVAL
print *, "wafs levels",pset%param(N)%level
@@ -476,20 +461,20 @@ SUBROUTINE MDL2STD_P()
IF (LVLS(IFD,IGET(iID)) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EGRID2(I,J) = HTFDCTL(IFD) ! P
ENDDO
ENDDO
- EGRID3(1:IM,JSTA:JEND)=QFD(1:IM,JSTA:JEND,IFD,1) ! T
- EGRID4(1:IM,JSTA:JEND)=QFD(1:IM,JSTA:JEND,IFD,2) ! Q
+ EGRID3(ISTA:IEND,JSTA:JEND)=QFD(ISTA:IEND,JSTA:JEND,IFD,1) ! T
+ EGRID4(ISTA:IEND,JSTA:JEND)=QFD(ISTA:IEND,JSTA:JEND,IFD,2) ! Q
EGRID1 = SPVAL
- CALL CALRH(EGRID2(1,jsta),EGRID3(1,jsta),EGRID4(1,jsta),EGRID1(1,jsta))
+ CALL CALRH(EGRID2(ista:iend,jsta:jend),EGRID3(ista:iend,jsta:jend),EGRID4(ista:iend,jsta:jend),EGRID1(ista:iend,jsta:jend))
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(EGRID1(I,J) < SPVAL) THEN
GRID1(I,J) = EGRID1(I,J)*100.
ELSE
@@ -502,10 +487,11 @@ SUBROUTINE MDL2STD_P()
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(iID))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(iID))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
+ do i=1,iend-ista+1
+ ii = ista+i-1
datapd(i,j,cfld) = GRID1(i,jj)
enddo
enddo
diff --git a/sorc/ncep_post.fd/MDL2THANDPV.f b/sorc/ncep_post.fd/MDL2THANDPV.f
index bc5d6efef..8d70c2ee4 100644
--- a/sorc/ncep_post.fd/MDL2THANDPV.f
+++ b/sorc/ncep_post.fd/MDL2THANDPV.f
@@ -1,44 +1,24 @@
!> @file
-!
-!> SUBPROGRAM: MDL2THANDPV VERT INTRP OF MODEL LVLS TO ISENTROPIC AND PV
-!! PRGRMMR: CHUANG ORG: W/NP22 DATE: 07-03-26
-!!
-!! ABSTRACT:
-!! FOR MOST APPLICATIONS THIS ROUTINE IS THE WORKHORSE
-!! OF THE POST PROCESSOR. IN A NUTSHELL IT INTERPOLATES
-!! DATA FROM MODEL TO THETA AND PV SURFACES.
-!!
-!! PROGRAM HISTORY
-!! 11-02-06 J. WANG ADD GRIB2 OPTION
-!! 14-03-06 S. Moorthi - updated for threading and some optimization
-!! 16-12-19 G.P. Lou - Added A-grid regional models
-!! 20-03-25 J MENG - remove grib1
-!! 20-03-25 J MENG - remove grib1
-!! 20-11-10 J MENG - USE UPP_MATH and UPP_PHYSICS MODULES
-!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend)
-!!
-!!
-!! USAGE: CALL MDL2THANDPV
-!! INPUT ARGUMENT LIST:
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! PVETC -
-!! P2TH -
-!! P2PV -
-!! COMMON - CTLBLK
-!! RQSTFLD
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN 90
-!! MACHINE : IBM SP
-!!
+!> @brief mdl2thandpv() vert intrp of model lvls to isentropic and PV.
+!>
+!> For most applications this routine is the workhorse
+!> of the post processor. In a nutshell it interpolates
+!> data from model to THETA and PV surfaces.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2007-03-26 | Chuang | Initial
+!> 2011-02-06 | J. Wang | Add GRIB2 Option
+!> 2014-03-06 | S. Moorthi | Updated for threading and some optimization
+!> 2016-12-19 | G.P. Lou | Added A-grid regional models
+!> 2020-03-25 | J Meng | Remove grib1
+!> 2020-03-25 | J Meng | Remove grib1
+!> 2020-11-10 | J Meng | Use UPP_MATH and UPP_PHYSICS Modules
+!> 2021-03-11 | B Cui | Change local arrays to dimension (im,jsta:jend)
+!> 2021-10-26 | J MENG | 2D DECOMPOSITION
+!>
+!> @author Chuang W/NP22 @date 2007-03-26
SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
!
@@ -48,8 +28,9 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
use masks, only: gdlat, gdlon, dx, dy
use physcons_post, only: con_eps, con_epsm1
use params_mod, only: dtr, small, erad, d608, rhmin
- use CTLBLK_mod, only: spval, lm, jsta_2l, jend_2u, jsta_2l, grib, cfld, datapd, fld_info,&
- im, jm, jsta, jend, jsta_m, jend_m, modelname, global,gdsdegr,me
+ use CTLBLK_mod, only: spval, lm, jsta_2l, jend_2u, grib, cfld, datapd, fld_info,&
+ im, jm, jsta, jend, jsta_m, jend_m, modelname, global,gdsdegr,me,&
+ ista, iend, ista_m, iend_m, ista_2l, iend_2u
use RQSTFLD_mod, only: iget, lvls, id, iavblfld, lvlsxml
use gridspec_mod, only: gridtype,dyval
use upp_physics, only: FPVSNEW
@@ -61,7 +42,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
!
integer,intent(in) :: kth, kpv
real, intent(in) :: th(kth), pv(kpv)
- real, dimension(im,jsta:jend) :: grid1, grid2
+ real, dimension(ista:iend,jsta:jend) :: grid1, grid2
real, dimension(kpv) :: pvpt, pvpb
LOGICAL IOOMG,IOALL
@@ -72,11 +53,14 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
, DUM1D9(:), DUM1D10(:),DUM1D11(:) &
, DUM1D12(:),DUM1D13(:),DUM1D14(:)
!
- real, dimension(IM,JSTA:JEND,KTH) :: UTH, VTH, HMTH, TTH, PVTH, &
+ real, dimension(ISTA:IEND,JSTA:JEND,KTH) :: UTH, VTH, HMTH, TTH, PVTH, &
SIGMATH, RHTH, OTH
- real, dimension(IM,JSTA:JEND,KPV) :: UPV, VPV, HPV, TPV, PPV, SPV
+ real, dimension(ISTA:IEND,JSTA:JEND,KPV) :: UPV, VPV, HPV, TPV, PPV, SPV
+ real, dimension(IM,2) :: GLATPOLES, COSLPOLES, PVPOLES
+ real, dimension(IM,2,LM) :: UPOLES, TPOLES, PPOLES
+ real, dimension(IM,JSTA:JEND) :: COSLTEMP, PVTEMP
!
- real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), wrk4(:,:), cosl(:,:)
+ real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), wrk4(:,:), cosl(:,:), dum2d(:,:)
real, allocatable :: tuv(:,:,:),pmiduv(:,:,:)
!
integer, dimension(im) :: iw, ie
@@ -88,7 +72,9 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
!******************************************************************************
!
! START MDL2TH.
-!
+!
+ if(me==0) write(0,*) 'MDL2THANDPV starts'
+!
! SET TOTAL NUMBER OF POINTS ON OUTPUT GRID.
!
!---------------------------------------------------------------
@@ -119,7 +105,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
do k=1,kth
!$omp parallel do private(i,j)
do j=jsta,jend
- do i=1,im
+ do i=ista,iend
UTH(i,j,k) = SPVAL
VTH(i,j,k) = SPVAL
HMTH(i,j,k) = SPVAL
@@ -134,7 +120,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
do k=1,kpv
!$omp parallel do private(i,j)
do j=jsta,jend
- do i=1,im
+ do i=ista,iend
UPV(i,j,k) = SPVAL
VPV(i,j,k) = SPVAL
HPV(i,j,k) = SPVAL
@@ -151,20 +137,24 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
ALLOCATE(DUM1D14(LM))
!
DO L=1,LM
- CALL EXCH(PMID(1:IM,JSTA_2L:JEND_2U,L))
- CALL EXCH(T(1:IM,JSTA_2L:JEND_2U,L))
- CALL EXCH(UH(1:IM,JSTA_2L:JEND_2U,L))
+ CALL EXCH(PMID(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L))
+ CALL EXCH(T(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L))
+ CALL EXCH(UH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L))
+ CALL EXCH(VH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L))
END DO
- CALL EXCH(GDLAT(1,JSTA_2L))
+ CALL EXCH(GDLAT(ISTA_2L,JSTA_2L))
+ CALL EXCH(GDLON(ISTA_2L,JSTA_2L))
! print *,' JSTA_2L=',JSTA_2L,' JSTA=',JSTA_2L,' JEND_2U=', &
! &JEND_2U,' JEND=',JEND,' IM=',IM
! print *,' GDLATa=',gdlat(1,:)
! print *,' GDLATb=',gdlat(im,:)
!
- allocate (wrk1(im,jsta:jend), wrk2(im,jsta:jend), &
- & wrk3(im,jsta:jend), cosl(im,jsta_2l:jend_2u))
- allocate (wrk4(im,jsta:jend))
+ allocate (wrk1(ista:iend,jsta:jend), wrk2(ista:iend,jsta:jend), &
+ & wrk3(ista:iend,jsta:jend), cosl(ista_2l:iend_2u,jsta_2l:jend_2u))
+ allocate (dum2d(ista_2l:iend_2u,jsta_2l:jend_2u))
+ allocate (wrk4(ista:iend,jsta:jend))
+
imb2 = im /2
eradi = 1.0 / erad
@@ -175,12 +165,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
ie(i) = i + 1
iw(i) = i - 1
enddo
- iw(1) = im
- ie(im) = 1
+! iw(1) = im
+! ie(im) = 1
!
!$omp parallel do private(i,j,ip1,im1)
DO J=JSTA,JEND
- do i=1,im
+ do i=ISTA,IEND
ip1 = ie(i)
im1 = iw(i)
cosl(i,j) = cos(gdlat(i,j)*dtr)
@@ -197,27 +187,31 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
wrk4(i,j) = wrk1(i,j) * wrk2(i,j) ! 1/dx
enddo
enddo
-! CALL EXCH(cosl(1,JSTA_2L))
CALL EXCH(cosl)
+
+ call fullpole(cosl,coslpoles)
+ call fullpole(gdlat(ista_2l:iend_2u,jsta_2l:jend_2u),glatpoles)
!$omp parallel do private(i,j,ii,tem)
DO J=JSTA,JEND
if (j == 1) then
- do i=1,im
+ do i=ISTA,IEND
ii = i + imb2
if (ii > im) ii = ii - im
- wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi
+ ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi
+ wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GLATPOLES(II,1))*DTR) !1/dphi
enddo
elseif (j == JM) then
- do i=1,im
+ do i=ISTA,IEND
ii = i + imb2
if (ii > im) ii = ii - im
- wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR) !1/dphi
+ ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR) !1/dphi
+ wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GLATPOLES(II,2))*DTR) !1/dphi
enddo
else
!print *,' j=',j,' GDLATJm1=',gdlat(:,j-1)
!print *,' j=',j,' GDLATJp1=',gdlat(:,j+1)
- do i=1,im
+ do i=ISTA,IEND
tem = GDLAT(I,J-1) - GDLAT(I,J+1)
if (abs(tem) > small) then
wrk3(i,j) = 1.0 / (tem*DTR) !1/dphi
@@ -232,7 +226,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
else !!global?
!$omp parallel do private(i,j)
DO J=JSTA_m,Jend_m
- DO I=2,im-1
+ DO I=ISTA_M,IEND_M
wrk2(i,j) = 0.5 / DX(I,J)
wrk3(i,j) = 0.5 / DY(I,J)
END DO
@@ -241,20 +235,26 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
! need to put T and P on V points for computing dp/dx for e grid
IF(GRIDTYPE == 'E')THEN
- allocate(tuv(1:im,jsta_2l:jend_2u,lm))
- allocate(pmiduv(1:im,jsta_2l:jend_2u,lm))
+ allocate(tuv(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
+ allocate(pmiduv(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
do l=1,lm
- call h2u(t(1:im,jsta_2l:jend_2u,l),tuv(1:im,jsta_2l:jend_2u,l))
- call h2u(pmid(1:im,jsta_2l:jend_2u,l),pmiduv(1:im,jsta_2l:jend_2u,l))
+ call h2u(t(ista_2l:iend_2u,jsta_2l:jend_2u,l),tuv(ista_2l:iend_2u,jsta_2l:jend_2u,l))
+ call h2u(pmid(ista_2l:iend_2u,jsta_2l:jend_2u,l),pmiduv(ista_2l:iend_2u,jsta_2l:jend_2u,l))
end do
end if
!add A-grid regional models
IF(GRIDTYPE == 'A')THEN
IF(MODELNAME == 'GFS' .or. global) THEN
+
+ DO L=1,LM
+ CALL FULLPOLE(PMID(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L),PPOLES(:,:,L))
+ CALL FULLPOLE( T(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L),TPOLES(:,:,L))
+ CALL FULLPOLE( UH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L),UPOLES(:,:,L))
+ ENDDO
!!$omp parallel do private(i,j,ip1,im1,ii,jj,l,es,dum1d1,dum1d2,dum1d3,dum1d4,dum1d5,dum1d6,dum1d14,tem)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
ip1 = ie(i)
im1 = iw(i)
ii = i + imb2
@@ -270,10 +270,13 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
DUM1D14(L) = Q(I,J,L) * (PMID(I,J,L)+CON_EPSM1*ES)/(CON_EPS*ES) ! RH
DUM1D1(L) = (PMID(ip1,J,L)- PMID(im1,J,L)) * wrk4(i,j) !dp/dx
DUM1D3(L) = (T(ip1,J,L) - T(im1,J,L)) * wrk4(i,j) !dt/dx
- DUM1D2(L) = (PMID(II,J,L) - PMID(I,J+1,L)) * tem !dp/dy
- DUM1D4(L) = (T(II,J,L) - T(I,J+1,L)) * tem !dt/dy
+ ! DUM1D2(L) = (PMID(II,J,L) - PMID(I,J+1,L)) * tem !dp/dy
+ DUM1D2(L) = (PPOLES(II,1,L) - PMID(I,J+1,L)) * tem !dp/dy
+ ! DUM1D4(L) = (T(II,J,L) - T(I,J+1,L)) * tem !dt/dy
+ DUM1D4(L) = (TPOLES(II,1,L) - T(I,J+1,L)) * tem !dt/dy
DUM1D6(L) = ((VH(ip1,J,L)-VH(im1,J,L))*wrk2(i,j) &
- & + (UH(II,J,L)*COSL(II,J) &
+ !& ! + (UH(II,J,L)*COSL(II,J) &
+ & + (UPOLES(II,1,L)*COSLPOLES(II,1) &
& + UH(I,J+1,L)*COSL(I,J+1))*wrk3(i,j))*wrk1(i,j) &
& + F(I,J)
END DO
@@ -305,11 +308,14 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
DUM1D14(L) = Q(I,J,L) * (PMID(I,J,L)+CON_EPSM1*ES)/(CON_EPS*ES) ! RH
DUM1D1(L) = (PMID(ip1,J,L)- PMID(im1,J,L)) * wrk4(i,j) !dp/dx
DUM1D3(L) = (T(ip1,J,L) - T(im1,J,L)) * wrk4(i,j) !dt/dx
- DUM1D2(L) = (PMID(I,J-1,L)-PMID(II,J,L)) * tem !dp/dy
- DUM1D4(L) = (T(I,J-1,L)-T(II,J,L)) * tem !dt/dy
+ ! DUM1D2(L) = (PMID(I,J-1,L)-PMID(II,J,L)) * tem !dp/dy
+ DUM1D2(L) = (PMID(I,J-1,L)-PPOLES(II,2,L)) * tem !dp/dy
+ ! DUM1D4(L) = (T(I,J-1,L)-T(II,J,L)) * tem !dt/dy
+ DUM1D4(L) = (T(I,J-1,L)-TPOLES(II,2,L)) * tem !dt/dy
DUM1D6(L) = ((VH(ip1,J,L)-VH(im1,J,L))* wrk2(i,j) &
& + (UH(I,J-1,L)*COSL(I,J-1) &
- & + UH(II,J,L)*COSL(II,J))*wrk3(i,j))*wrk1(i,j) &
+ !& ! + UH(II,J,L)*COSL(II,J))*wrk3(i,j))*wrk1(i,j) &
+ & + UPOLES(II,2,L)*COSLPOLES(II,2))*wrk3(i,j))*wrk1(i,j) &
& + F(I,J)
END DO
ELSE !pole point, compute at j=jm-1
@@ -357,7 +363,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
DO L=1,LM
print*,pmid(i,j,l),dum1d1(l),dum1d2(l),dum1d5(l) &
,dum1d3(l),dum1d4(l),zmid(i,j,l),uh(i,j,l),vh(i,j,l) &
- ,dum1d6(l)
+ ,dum1d6(l),L
end do
end if
@@ -371,7 +377,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
,'hm,s,bvf2,pvn,theta,sigma,pvu= '
DO L=1,LM
print*,dum1d7(l),dum1d8(l),dum1d9(l),dum1d10(l),dum1d11(l) &
- ,dum1d12(l),dum1d13(l)
+ ,dum1d12(l),dum1d13(l),L
end do
end if
@@ -410,7 +416,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
DO J=JSTA_m,Jend_m
JMT2=JM/2+1
TPHI=(J-JMT2)*(DYVAL/gdsdegr)*DTR
- DO I=2,im-1
+ DO I=ISTA_M,IEND_M
ip1 = i + 1
im1 = i - 1
tem = wrk3(i,j) * eradi
@@ -450,7 +456,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
,'hm,s,bvf2,pvn,theta,sigma,pvu,pvort= '
DO L=1,LM
print*,dum1d7(l),dum1d8(l),dum1d9(l),dum1d10(l),dum1d11(l) &
- ,dum1d12(l),dum1d13(l),DUM1D6(l)
+ ,dum1d12(l),dum1d13(l),DUM1D6(l),L
end do
end if
@@ -486,14 +492,15 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
ENDIF !regional models and A-grid end here
!-----------------------------------------------------------------
ELSE IF (GRIDTYPE == 'B')THEN
- allocate(DVDXL(1:im,jsta_m:jend_m,lm))
- allocate(DUDYL(1:im,jsta_m:jend_m,lm))
- allocate(UAVGL(1:im,jsta_m:jend_m,lm))
+ allocate(DVDXL(ista_m:iend_m,jsta_m:jend_m,lm))
+ allocate(DUDYL(ista_m:iend_m,jsta_m:jend_m,lm))
+ allocate(UAVGL(ista_m:iend_m,jsta_m:jend_m,lm))
DO L=1,LM
- CALL EXCH(VH(1:IM,JSTA_2L:JEND_2U,L))
+ CALL EXCH(VH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L))
+ CALL EXCH(UH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L))
CALL DVDXDUDY(UH(:,:,L),VH(:,:,L))
DO J=JSTA_m,Jend_m
- DO I=2,im-1
+ DO I=ISTA_M,IEND_M
DVDXL(I,J,L) = DDVDX(I,J)
DUDYL(I,J,L) = DDUDY(I,J)
UAVGL(I,J,L) = UUAVG(I,J)
@@ -503,7 +510,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
DO J=JSTA_m,Jend_m
JMT2=JM/2+1
TPHI=(J-JMT2)*(DYVAL/gdsdegr)*DTR
- DO I=2,im-1
+ DO I=ISTA_M,IEND_M
ip1 = i + 1
im1 = i - 1
DO L=1,LM
@@ -580,7 +587,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
TPHI = (J-JMT2)*(DYVAL/gdsdegr)*DTR
IHW= - MOD(J,2)
IHE = IHW + 1
- DO I=2,im-1
+ DO I=ISTA_M,IEND_M
ip1 = i + 1
im1 = i - 1
DO L=1,LM
@@ -673,7 +680,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
IF(LVLS(LP,IGET(332)) > 0 .OR. LVLS(LP,IGET(333)) > 0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = UTH(I,J,LP)
GRID2(I,J) = VTH(I,J,LP)
ENDDO
@@ -682,21 +689,23 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET(332))
fld_info(cfld)%lvl = LVLSXML(lp,IGET(332))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET(333))
fld_info(cfld)%lvl = LVLSXML(lp,IGET(333))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -731,7 +740,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
! END IF
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = TTH(I,J,LP)
ENDDO
ENDDO
@@ -739,11 +748,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
cfld = cfld + 1
fld_info(cfld)%ifld=IAVBLFLD(IGET(334))
fld_info(cfld)%lvl=LVLSXML(lp,IGET(334))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -754,14 +764,30 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
!
IF(IGET(335) > 0) THEN
IF(LVLS(LP,IGET(335)) > 0)THEN
- call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) &
- ,SPVAL,PVTH(1:IM,JSTA:JEND,LP))
- IF(1>=jsta .and. 1<=jend)print*,'PVTH at N POLE= ' &
- ,pvth(1,1,lp),pvth(im/2,1,lp) &
- ,pvth(10,10,lp),pvth(im/2,10,lp),SPVAL,grib,LP
+ ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) &
+ ! ,SPVAL,PVTH(1:IM,JSTA:JEND,LP))
+ ! IF(1>=jsta .and. 1<=jend)print*,'PVTH at N POLE= ' &
+ ! ,pvth(1,1,lp),pvth(im/2,1,lp) &
+ ! ,pvth(10,10,lp),pvth(im/2,10,lp),SPVAL,grib,LP
+ DUM2D(ISTA:IEND,JSTA:JEND)=PVTH(ISTA:IEND,JSTA:JEND,LP)
+ CALL EXCH(DUM2D)
+ CALL FULLPOLE(DUM2D,PVPOLES)
+ COSLTEMP=SPVAL
+ IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1)
+ IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2)
+ PVTEMP=SPVAL
+ IF(JSTA== 1) PVTEMP(1:IM, 1)=PVPOLES(1:IM,1)
+ IF(JEND==JM) PVTEMP(1:IM,JM)=PVPOLES(1:IM,2)
+
+ call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) &
+ ,SPVAL,PVTEMP(1:IM,JSTA:JEND))
+
+ IF(JSTA== 1) PVTH(ISTA:IEND, 1,LP)=PVTEMP(ISTA:IEND, 1)
+ IF(JEND==JM) PVTH(ISTA:IEND,JM,LP)=PVTEMP(ISTA:IEND,JM)
+
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(PVTH(I,J,LP) /= SPVAL)THEN
GRID1(I,J) = PVTH(I,J,LP)*1.0E-6
ELSE
@@ -773,11 +799,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(335))
fld_info(cfld)%lvl=LVLSXML(lp,IGET(335))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -790,7 +817,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
IF(LVLS(LP,IGET(353)) > 0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = HMTH(I,J,LP)
ENDDO
ENDDO
@@ -798,11 +825,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(353))
fld_info(cfld)%lvl=LVLSXML(lp,IGET(353))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -815,7 +843,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
IF(LVLS(LP,IGET(351)) > 0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = SIGMATH(I,J,LP)
ENDDO
ENDDO
@@ -823,11 +851,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(351))
fld_info(cfld)%lvl=LVLSXML(lp,IGET(351))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -840,7 +869,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
IF(LVLS(LP,IGET(352)) > 0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(RHTH(I,J,LP) /= SPVAL) THEN
GRID1(I,J) = 100.0 * MIN(1.,MAX(RHmin,RHTH(I,J,LP)))
ELSE
@@ -852,11 +881,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(352))
fld_info(cfld)%lvl=LVLSXML(lp,IGET(352))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -869,7 +899,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
IF(LVLS(LP,IGET(378)) > 0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = OTH(I,J,LP)
ENDDO
ENDDO
@@ -877,11 +907,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(378))
fld_info(cfld)%lvl=LVLSXML(lp,IGET(378))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -895,11 +926,27 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
IF(IGET(336) > 0.OR.IGET(337) > 0)THEN
IF(LVLS(LP,IGET(336)) > 0.OR.LVLS(LP,IGET(337)) > 0)THEN
! GFS use lon avg as one scaler value for pole point
- call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) &
- ,SPVAL,VPV(1:IM,JSTA:JEND,LP))
+ ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) &
+ ! ,SPVAL,VPV(1:IM,JSTA:JEND,LP))
+ DUM2D(ISTA:IEND,JSTA:JEND)=VPV(ISTA:IEND,JSTA:JEND,LP)
+ CALL EXCH(DUM2D)
+ CALL FULLPOLE(DUM2D,PVPOLES)
+ COSLTEMP=SPVAL
+ IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1)
+ IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2)
+ PVTEMP=SPVAL
+ IF(JSTA== 1) PVTEMP(1:IM, 1)=PVPOLES(1:IM,1)
+ IF(JEND==JM) PVTEMP(1:IM,JM)=PVPOLES(1:IM,2)
+
+ call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) &
+ ,SPVAL,PVTEMP(1:IM,JSTA:JEND))
+
+ IF(JSTA== 1) VPV(ISTA:IEND, 1,LP)=PVTEMP(ISTA:IEND, 1)
+ IF(JEND==JM) VPV(ISTA:IEND,JM,LP)=PVTEMP(ISTA:IEND,JM)
+
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = UPV(I,J,LP)
GRID2(I,J) = VPV(I,J,LP)
ENDDO
@@ -908,21 +955,23 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(336))
fld_info(cfld)%lvl=LVLSXML(lp,IGET(336))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(337))
fld_info(cfld)%lvl=LVLSXML(lp,IGET(337))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -935,11 +984,27 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
IF(IGET(338) > 0)THEN
IF(LVLS(LP,IGET(338)) > 0)THEN
! GFS use lon avg as one scaler value for pole point
- call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) &
- ,SPVAL,TPV(1:IM,JSTA:JEND,LP))
+ ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) &
+ ! ,SPVAL,TPV(1:IM,JSTA:JEND,LP))
+ DUM2D(ISTA:IEND,JSTA:JEND)=TPV(ISTA:IEND,JSTA:JEND,LP)
+ CALL EXCH(DUM2D)
+ CALL FULLPOLE(DUM2D,PVPOLES)
+ COSLTEMP=SPVAL
+ IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1)
+ IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2)
+ PVTEMP=SPVAL
+ IF(JSTA== 1) PVTEMP(1:IM, 1)=PVPOLES(1:IM,1)
+ IF(JEND==JM) PVTEMP(1:IM,JM)=PVPOLES(1:IM,2)
+
+ call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) &
+ ,SPVAL,PVTEMP(1:IM,JSTA:JEND))
+
+ IF(JSTA== 1) TPV(ISTA:IEND, 1,LP)=PVTEMP(ISTA:IEND, 1)
+ IF(JEND==JM) TPV(ISTA:IEND,JM,LP)=PVTEMP(ISTA:IEND,JM)
+
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = TPV(I,J,LP)
ENDDO
ENDDO
@@ -947,11 +1012,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(338))
fld_info(cfld)%lvl=LVLSXML(lp,IGET(338))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -963,11 +1029,27 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
IF(IGET(339) > 0) THEN
IF(LVLS(LP,IGET(339)) > 0)THEN
! GFS use lon avg as one scaler value for pole point
- call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) &
- ,SPVAL,HPV(1:IM,JSTA:JEND,LP))
+ ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) &
+ ! ,SPVAL,HPV(1:IM,JSTA:JEND,LP))
+ DUM2D(ISTA:IEND,JSTA:JEND)=HPV(ISTA:IEND,JSTA:JEND,LP)
+ CALL EXCH(DUM2D)
+ CALL FULLPOLE(DUM2D,PVPOLES)
+ COSLTEMP=SPVAL
+ IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1)
+ IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2)
+ PVTEMP=SPVAL
+ IF(JSTA== 1) PVTEMP(1:IM, 1)=PVPOLES(1:IM,1)
+ IF(JEND==JM) PVTEMP(1:IM,JM)=PVPOLES(1:IM,2)
+
+ call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) &
+ ,SPVAL,PVTEMP(1:IM,JSTA:JEND))
+
+ IF(JSTA== 1) HPV(ISTA:IEND, 1,LP)=PVTEMP(ISTA:IEND, 1)
+ IF(JEND==JM) HPV(ISTA:IEND,JM,LP)=PVTEMP(ISTA:IEND,JM)
+
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = HPV(I,J,LP)
ENDDO
ENDDO
@@ -975,11 +1057,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(339))
fld_info(cfld)%lvl=LVLSXML(lp,IGET(339))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -991,11 +1074,27 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
IF(IGET(340) > 0) THEN
IF(LVLS(LP,IGET(340)) > 0)THEN
! GFS use lon avg as one scaler value for pole point
- call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) &
- ,SPVAL,PPV(1:IM,JSTA:JEND,LP))
+ ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) &
+ ! ,SPVAL,PPV(1:IM,JSTA:JEND,LP))
+ DUM2D(ISTA:IEND,JSTA:JEND)=PPV(ISTA:IEND,JSTA:JEND,LP)
+ CALL EXCH(DUM2D)
+ CALL FULLPOLE(DUM2D,PVPOLES)
+ COSLTEMP=SPVAL
+ IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1)
+ IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2)
+ PVTEMP=SPVAL
+ IF(JSTA== 1) PVTEMP(1:IM, 1)=PVPOLES(1:IM,1)
+ IF(JEND==JM) PVTEMP(1:IM,JM)=PVPOLES(1:IM,2)
+
+ call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) &
+ ,SPVAL,PVTEMP(1:IM,JSTA:JEND))
+
+ IF(JSTA== 1) PPV(ISTA:IEND, 1,LP)=PVTEMP(ISTA:IEND, 1)
+ IF(JEND==JM) PPV(ISTA:IEND,JM,LP)=PVTEMP(ISTA:IEND,JM)
+
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = PPV(I,J,LP)
ENDDO
ENDDO
@@ -1003,11 +1102,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(340))
fld_info(cfld)%lvl=LVLSXML(lp,IGET(340))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1019,11 +1119,27 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
IF(IGET(341) > 0) THEN
IF(LVLS(LP,IGET(341)) > 0)THEN
! GFS use lon avg as one scaler value for pole point
- call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) &
- ,SPVAL,SPV(1:IM,JSTA:JEND,LP))
+ ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) &
+ ! ,SPVAL,SPV(1:IM,JSTA:JEND,LP))
+ DUM2D(ISTA:IEND,JSTA:JEND)=SPV(ISTA:IEND,JSTA:JEND,LP)
+ CALL EXCH(DUM2D)
+ CALL FULLPOLE(DUM2D,PVPOLES)
+ COSLTEMP=SPVAL
+ IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1)
+ IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2)
+ PVTEMP=SPVAL
+ IF(JSTA== 1) PVTEMP(1:IM, 1)=PVPOLES(1:IM,1)
+ IF(JEND==JM) PVTEMP(1:IM,JM)=PVPOLES(1:IM,2)
+
+ call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) &
+ ,SPVAL,PVTEMP(1:IM,JSTA:JEND))
+
+ IF(JSTA== 1) SPV(ISTA:IEND, 1,LP)=PVTEMP(ISTA:IEND, 1)
+ IF(JEND==JM) SPV(ISTA:IEND,JM,LP)=PVTEMP(ISTA:IEND,JM)
+
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = SPV(I,J,LP)
ENDDO
ENDDO
@@ -1031,11 +1147,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(341))
fld_info(cfld)%lvl=LVLSXML(lp,IGET(341))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1046,10 +1163,10 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv)
DEALLOCATE(DUM1D1,DUM1D2,DUM1D3,DUM1D4,DUM1D5,DUM1D6,DUM1D7, &
DUM1D8,DUM1D9,DUM1D10,DUM1D11,DUM1D12,DUM1D13, &
- DUM1D14,wrk1, wrk2, wrk3, wrk4, cosl)
+ DUM1D14,wrk1, wrk2, wrk3, wrk4, cosl, dum2d)
END IF ! end of selection for isentropic and constant PV fields
- if(me==0)print *,'end of MDL2THandpv'
+ if(me==0) write(0,*) 'MDL2THANDPV ends'
!
!
! END OF ROUTINE.
diff --git a/sorc/ncep_post.fd/MDLFLD.f b/sorc/ncep_post.fd/MDLFLD.f
index e1beeefc3..b3dbe03f3 100644
--- a/sorc/ncep_post.fd/MDLFLD.f
+++ b/sorc/ncep_post.fd/MDLFLD.f
@@ -43,6 +43,7 @@
!! 20-11-10 J MENG - USE UPP_MATH MODULE
!! 20-11-10 J MENG - USE UPP_PHYSICS MODULE
!! 21-04-01 J MENG - COMPUTATION ON DEFINED POINTS ONLY
+!! 21-07-07 J MENG - 2D DECOMPOSITION
!!
!! USAGE: CALL MDLFLD
!! INPUT ARGUMENT LIST:
@@ -97,10 +98,11 @@ SUBROUTINE MDLFLD
tops, dsnow, drain,const_ng1, const_ng2, gon, topg, dgraupel
use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, grib, cfld, datapd,&
fld_info, modelname, imp_physics, dtq2, spval, icount_calmict,&
- me, dt, avrain, theat, ifhr, ifmin, avcnvc, lp1, im, jm, aqfcmaq_on
+ me, dt, avrain, theat, ifhr, ifmin, avcnvc, lp1, im, jm, &
+ ista, iend, ista_2l, iend_2u, aqfcmaq_on
use rqstfld_mod, only: iget, id, lvls, iavblfld, lvlsxml
use gridspec_mod, only: gridtype,maptype,dxval
- use upp_physics, only: CALRH, CALCAPE
+ use upp_physics, only: CALRH, CALCAPE, CALVOR
use upp_math, only: H2U, H2V, U2H, V2H
!
@@ -120,7 +122,7 @@ SUBROUTINE MDLFLD
REAL CC(10), PPT(10)
DATA CC / 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1.0 /
DATA PPT/ 0., .14, .31, .70, 1.6, 3.4, 7.7, 17., 38., 85. /
- INTEGER, dimension(im,jsta_2l:jend_2u) :: ICBOT, ICTOP, LPBL
+ INTEGER, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: ICBOT, ICTOP, LPBL
!
! DECLARE VARIABLES.
@@ -129,7 +131,7 @@ SUBROUTINE MDLFLD
LOGICAL NMM_GFSmicro
LOGiCAL Model_Radar
real, dimension(im,jm) :: GRID1, GRID2
- real, dimension(im,jsta_2l:jend_2u) :: EGRID1, EGRID2, EGRID3, EGRID4, EGRID5,&
+ real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: EGRID1, EGRID2, EGRID3, EGRID4, EGRID5,&
EL0, P1D, T1D, Q1D, C1D, &
FI1D, FR1D, FS1D, QW1, QI1, &
QR1, QS1, CUREFL_S, &
@@ -160,8 +162,8 @@ SUBROUTINE MDLFLD
integer ks,nsmooth
REAL SDUMMY(IM,2),dxm
! added to calculate cape and cin for icing
- real, dimension(im,jsta:jend) :: dummy, cape, cin
- integer idummy(IM,jsta:jend)
+ real, dimension(ista:iend,jsta:jend) :: dummy, cape, cin
+ integer idummy(ista:iend,jsta:jend)
real, PARAMETER :: ZSL=0.0, TAUCR=RD*GI*290.66, CONST=0.005*G/RD, GORD=G/RD
logical, parameter :: debugprint = .false.
@@ -186,7 +188,7 @@ SUBROUTINE MDLFLD
! IF (ABS(MAXVAL(REF_10CM)-SPVAL)>SMALL)Model_Radar=.True.
check_ref: DO L=1,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(ABS(REF_10CM(I,J,L)-SPVAL)>SMALL) THEN
Model_Radar=.True.
exit check_ref
@@ -196,9 +198,9 @@ SUBROUTINE MDLFLD
ENDDO check_ref
if(debugprint .and. me==0)print*,'Did post read in model derived radar ref ',Model_Radar, &
'MODELNAME=',trim(MODELNAME),' imp_physics=',imp_physics
- ALLOCATE(EL (IM,JSTA_2L:JEND_2U,LM))
- ALLOCATE(RICHNO (IM,JSTA_2L:JEND_2U,LM))
- ALLOCATE(PBLRI (IM,JSTA_2L:JEND_2U))
+ ALLOCATE(EL (ista_2l:iend_2u,JSTA_2L:JEND_2U,LM))
+ ALLOCATE(RICHNO (ista_2l:iend_2u,JSTA_2L:JEND_2U,LM))
+ ALLOCATE(PBLRI (ista_2l:iend_2u,JSTA_2L:JEND_2U))
!
! SECOND, STANDARD NGM SEA LEVEL PRESSURE.
IF (IGET(105) > 0 .OR. IGET(445) > 0) THEN
@@ -207,18 +209,19 @@ SUBROUTINE MDLFLD
IF (IGET(105) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = SLP(I,J)
ENDDO
ENDDO
if(grib=="grib2") then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(105))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -233,7 +236,7 @@ SUBROUTINE MDLFLD
! print*,'DTQ2 in MDLFLD= ',DTQ2
RDTPHS=24.*3.6E6/DTQ2
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF ((HBOT(I,J)-HTOP(I,J)) <= 1.0) THEN
ICBOT(I,J)=0
ICTOP(I,J)=0
@@ -261,7 +264,7 @@ SUBROUTINE MDLFLD
! CNVCFR(I,J)=100.*CFRdum
CNVCFR(I,J)=CFRdum
ENDIF !--- End IF (HBOT(I,J)-HTOP(I,J) <= 1.0) ...
- ENDDO !--- DO I=1,IM
+ ENDDO !--- DO I=ista,iend
ENDDO !--- DO J=JSTA,JEND
ENDIF !-- IF (MODELNAME=='NMM' .OR. imp_physics==5) THEN
!
@@ -279,7 +282,7 @@ SUBROUTINE MDLFLD
.or. NMM_GFSmicro)THEN
RDTPHS=3.6E6/DTQ2
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
CUPRATE=RDTPHS*CPRATE(I,J) !--- Cu precip rate, R (mm/h)
! CUPRATE=CUPPT(I,J)*1000./TRDLW !--- mm/h
Zfrz(I,J)=ZMID(I,J,NINT(LMH(I,J))) !-- Initialize to lowest model level
@@ -315,7 +318,7 @@ SUBROUTINE MDLFLD
if(icount_calmict==0)then !only call calmict once in multiple grid processing
DO L=1,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
P1D(I,J)=PMID(I,J,L)
T1D(I,J)=T(I,J,L)
Q1D(I,J)=Q(I,J,L)
@@ -368,7 +371,7 @@ SUBROUTINE MDLFLD
refl_miss: IF (Model_Radar) THEN
! - Model output DBZ is present - proceed with calc
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(P1D(I,J) LLMH) THEN
QQW(I,J,L) = D00
@@ -495,7 +498,7 @@ SUBROUTINE MDLFLD
ELSE IF(MODELNAME == 'NMM' .and. GRIDTYPE=='B' .and. imp_physics==99)THEN !NMMB+Zhao
DO L=1,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
LLMH = NINT(LMH(I,J))
IF (L > LLMH) THEN
QQW(I,J,L) = D00
@@ -523,7 +526,7 @@ SUBROUTINE MDLFLD
ELSE IF(MODELNAME == 'NMM' .and. GRIDTYPE=='B' .and. imp_physics==6)THEN !NMMB+WSM6
DO L=1,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
LLMH = NINT(LMH(I,J))
IF (L > LLMH) THEN
QQW(I,J,L)=D00
@@ -562,7 +565,7 @@ SUBROUTINE MDLFLD
.and. imp_physics==8)THEN !NMMB or FV3R +THOMPSON
DO L=1,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
DBZ(I,J,L)=REF_10CM(I,J,L)
ENDDO
ENDDO
@@ -570,7 +573,7 @@ SUBROUTINE MDLFLD
ELSE IF(imp_physics==99 .or. imp_physics==98)THEN ! Zhao MP
DO L=1,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
DBZ(I,J,L)=SPVAL
ENDDO
ENDDO
@@ -588,7 +591,7 @@ SUBROUTINE MDLFLD
! Chuang: add convective contribution for all MP schemes
RDTPHS=3.6E6/DTQ2
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
CUPRATE=RDTPHS*CPRATE(I,J) !--- Cu precip rate, R (mm/h)
Zfrz(I,J)=ZMID(I,J,NINT(LMH(I,J))) !-- Initialize to lowest model level
DO L=1,NINT(LMH(I,J)) !-- Start from the top, work down
@@ -620,7 +623,7 @@ SUBROUTINE MDLFLD
!$omp parallel do private(i,j,l,curefl,fctr,dens,llmh,lctop,delz,ze_nc)
DO L=1,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
!--- Estimate radar reflectivity factor from convection at level L
!
CUREFL(I,J)=0.
@@ -737,7 +740,7 @@ SUBROUTINE MDLFLD
ze_gmax = -1.E30
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
refl(i,j) = -10.
ze_max = -10.
@@ -885,7 +888,7 @@ SUBROUTINE MDLFLD
! ABSOLUTE VORTICITY ON MDL SURFACES.
!
!
- allocate (RH3D(im,jsta_2l:jend_2u,lm))
+ allocate (RH3D(ista_2l:iend_2u,jsta_2l:jend_2u,lm))
IF ( (IGET(001)>0).OR.(IGET(077)>0).OR. &
(IGET(002)>0).OR.(IGET(003)>0).OR. &
(IGET(004)>0).OR.(IGET(005)>0).OR. &
@@ -921,7 +924,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = PMID(I,J,LL)
ENDDO
ENDDO
@@ -929,11 +932,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(001))
fld_info(cfld)%lvl=LVLSXML(L,IGET(001))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -948,7 +952,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = QQW(I,J,LL)
if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0
ENDDO
@@ -957,11 +961,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(124))
fld_info(cfld)%lvl=LVLSXML(L,IGET(124))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -973,9 +978,9 @@ SUBROUTINE MDLFLD
IF (IGET(125) > 0) THEN
IF (LVLS(L,IGET(125)) > 0) THEN
LL=LM-L+1
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = QQI(I,J,LL)
if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0
ENDDO
@@ -984,11 +989,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(125))
fld_info(cfld)%lvl=LVLSXML(L,IGET(125))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1002,7 +1008,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = QQR(I,J,LL)
if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0
ENDDO
@@ -1011,11 +1017,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(181))
fld_info(cfld)%lvl=LVLSXML(L,IGET(181))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1029,7 +1036,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = QQS(I,J,LL)
if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0
ENDDO
@@ -1038,11 +1045,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(182))
fld_info(cfld)%lvl=LVLSXML(L,IGET(182))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1056,7 +1064,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
if(QQG(I,J,LL) < 1.e-12) QQG(I,J,LL) = 0. !tgs
GRID1(I,J) = QQG(I,J,LL)
ENDDO
@@ -1065,11 +1073,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(415))
fld_info(cfld)%lvl=LVLSXML(L,IGET(415))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1083,7 +1092,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
if(QQNW(I,J,LL) < 1.e-8) QQNW(I,J,LL) = 0. !tgs
GRID1(I,J) = QQNW(I,J,LL)
ENDDO
@@ -1092,11 +1101,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(747))
fld_info(cfld)%lvl=LVLSXML(L,IGET(747))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1110,7 +1120,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
if(QQNI(I,J,LL) < 1.e-8) QQNI(I,J,LL) = 0. !tgs
GRID1(I,J) = QQNI(I,J,LL)
ENDDO
@@ -1119,11 +1129,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(752))
fld_info(cfld)%lvl=LVLSXML(L,IGET(752))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1137,7 +1148,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
if(QQNR(I,J,LL) < 1.e-8) QQNR(I,J,LL) = 0. !tgs
GRID1(I,J) = QQNR(I,J,LL)
ENDDO
@@ -1146,11 +1157,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(754))
fld_info(cfld)%lvl=LVLSXML(L,IGET(754))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1162,7 +1174,7 @@ SUBROUTINE MDLFLD
IF (LVLS(L,IGET(766)) > 0)THEN
LL=LM-L+1
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
if(QQNWFA(I,J,LL)<1.e-8)QQNWFA(I,J,LL)=0. !tgs
GRID1(I,J)=QQNWFA(I,J,LL)
ENDDO
@@ -1171,7 +1183,7 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(766))
fld_info(cfld)%lvl=LVLSXML(L,IGET(766))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1182,7 +1194,7 @@ SUBROUTINE MDLFLD
IF (LVLS(L,IGET(767)) > 0)THEN
LL=LM-L+1
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
if(QQNIFA(I,J,LL)<1.e-8)QQNIFA(I,J,LL)=0. !tgs
GRID1(I,J)=QQNIFA(I,J,LL)
ENDDO
@@ -1191,7 +1203,7 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(767))
fld_info(cfld)%lvl=LVLSXML(L,IGET(767))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1203,7 +1215,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(abs(CFR(I,J,LL)-SPVAL) > SMALL) &
& GRID1(I,J) = CFR(I,J,LL)*H100
ENDDO
@@ -1213,11 +1225,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(145))
fld_info(cfld)%lvl=LVLSXML(L,IGET(145))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1231,7 +1244,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(MODELNAME == 'RAPR') THEN
GRID1(I,J) = CFR(I,J,LL)
ELSE
@@ -1243,11 +1256,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(774))
fld_info(cfld)%lvl=LVLSXML(L,IGET(774))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1270,14 +1284,14 @@ SUBROUTINE MDLFLD
IF(IMP_PHYSICS == 8 .or. IMP_PHYSICS == 28) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = REF_10CM(I,J,LL)
ENDDO
ENDDO
ELSE
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = DBZ(I,J,LL)
ENDDO
ENDDO
@@ -1288,11 +1302,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(250))
fld_info(cfld)%lvl=LVLSXML(L,IGET(250))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1307,7 +1322,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = CWM(I,J,LL)
ENDDO
ENDDO
@@ -1315,11 +1330,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(199))
fld_info(cfld)%lvl=LVLSXML(L,IGET(199))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1333,7 +1349,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = F_rain(I,J,LL)
ENDDO
ENDDO
@@ -1341,11 +1357,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(185))
fld_info(cfld)%lvl=LVLSXML(L,IGET(185))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1359,7 +1376,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = F_ice(I,J,LL)
ENDDO
ENDDO
@@ -1367,11 +1384,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(186))
fld_info(cfld)%lvl=LVLSXML(L,IGET(186))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1386,7 +1404,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = F_RimeF(I,J,LL)
ENDDO
ENDDO
@@ -1394,11 +1412,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(187))
fld_info(cfld)%lvl=LVLSXML(L,IGET(187))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1412,7 +1431,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = ZMID(I,J,LL)
ENDDO
ENDDO
@@ -1420,11 +1439,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(077))
fld_info(cfld)%lvl=LVLSXML(L,IGET(077))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1438,7 +1458,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = T(I,J,LL)
ENDDO
ENDDO
@@ -1446,11 +1466,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(002))
fld_info(cfld)%lvl=LVLSXML(L,IGET(002))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1464,7 +1485,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(T(I,J,LL)0) THEN
!HC IF (LVLS(L,IGET(124))>0) THEN
!HC DO J=JSTA,JEND
-!HC DO I=1,IM
+!HC DO I=ista,iend
!HC IF(CWM(I,J,L)<0..AND.CWM(I,J,L)>-1.E-10)
!HC 1 CWM(I,J,L)=0.
!HC GRID1(I,J)=CWM(I,J,L)
!HC ENDDO
!HC ENDDO
!HC ID(1:25) = 0
-!HC CALL GRIBIT(IGET(124),L,GRID1,IM,JM)
+!HC CALL GRIBIT(IGET(124),L,GRIDista,iend,JM)
!HC ENDIF
!HC ENDIF
!
@@ -1943,12 +1978,12 @@ SUBROUTINE MDLFLD
! IF (IGET(125)>0) THEN
! IF (LVLS(L,IGET(125))>0) THEN
! DO J=JSTA,JEND
-! DO I=1,IM
+! DO I=ista,iend
! GRID1(I,J)=QICE(I,J,L)
! ENDDO
! ENDDO
! ID(1:25) = 0
-! CALL GRIBIT(IGET(125),L,GRID1,IM,JM)
+! CALL GRIBIT(IGET(125),L,GRIDista,iend,JM)
! ENDIF
! ENDIF
!
@@ -1958,12 +1993,12 @@ SUBROUTINE MDLFLD
! IF (IGET(145)>0) THEN
! IF (LVLS(L,IGET(145))>0) THEN
! DO J=JSTA,JEND
-! DO I=1,IM
+! DO I=ista,iend
! GRID1(I,J)=CFRC(I,J,L)
! ENDDO
! ENDDO
! ID(1:25) = 0
-! CALL GRIBIT(IGET(145),L,GRID1,IM,JM)
+! CALL GRIBIT(IGET(145),L,GRIDista,iend,JM)
! ENDIF
! ENDIF
!
@@ -1974,7 +2009,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = TTND(I,J,LL)
ENDDO
ENDDO
@@ -1982,11 +2017,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(140))
fld_info(cfld)%lvl=LVLSXML(L,IGET(140))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2000,7 +2036,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = RSWTT(I,J,LL)
ENDDO
ENDDO
@@ -2008,11 +2044,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(040))
fld_info(cfld)%lvl=LVLSXML(L,IGET(040))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2026,7 +2063,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = RLWTT(I,J,LL)
ENDDO
ENDDO
@@ -2034,11 +2071,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(041))
fld_info(cfld)%lvl=LVLSXML(L,IGET(041))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2057,9 +2095,9 @@ SUBROUTINE MDLFLD
ELSE
RRNUM=0.
ENDIF
-!$omp parallel do
+!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(TRAIN(I,J,LL)ug/m3
ENDDO
@@ -2234,11 +2276,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(995))
fld_info(cfld)%lvl=LVLSXML(L,IGET(995))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2257,7 +2300,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(PMID(I,J,LL)ug/m3
@@ -2299,11 +2343,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(629))
fld_info(cfld)%lvl=LVLSXML(L,IGET(629))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2316,7 +2361,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(DUST(I,J,LL,2)ug/m3
@@ -2329,11 +2374,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(630))
fld_info(cfld)%lvl=LVLSXML(L,IGET(630))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2346,7 +2392,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(DUST(I,J,LL,3)ug/m3
@@ -2359,11 +2405,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(631))
fld_info(cfld)%lvl=LVLSXML(L,IGET(631))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2376,7 +2423,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(DUST(I,J,LL,4)ug/m3
@@ -2389,11 +2436,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(632))
fld_info(cfld)%lvl=LVLSXML(L,IGET(632))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2406,7 +2454,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(DUST(I,J,LL,5)ug/m3
@@ -2419,11 +2467,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(633))
fld_info(cfld)%lvl=LVLSXML(L,IGET(633))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2436,7 +2485,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(SALT(I,J,LL,1)ug/m3
ELSE
@@ -2448,11 +2497,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(634))
fld_info(cfld)%lvl=LVLSXML(L,IGET(634))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2465,7 +2515,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(SALT(I,J,LL,2)ug/m3
ELSE
@@ -2477,11 +2527,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(635))
fld_info(cfld)%lvl=LVLSXML(L,IGET(635))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2494,7 +2545,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(SALT(I,J,LL,3)ug/m3
ELSE
@@ -2506,11 +2557,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(636))
fld_info(cfld)%lvl=LVLSXML(L,IGET(636))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2523,7 +2575,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(SALT(I,J,LL,4)ug/m3
ELSE
@@ -2535,11 +2587,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(637))
fld_info(cfld)%lvl=LVLSXML(L,IGET(637))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2552,7 +2605,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(SALT(I,J,LL,5)ug/m3
ELSE
@@ -2564,11 +2617,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(638))
fld_info(cfld)%lvl=LVLSXML(L,IGET(638))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2581,7 +2635,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(SUSO(I,J,LL,1)ug/m3
@@ -2594,11 +2648,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(639))
fld_info(cfld)%lvl=LVLSXML(L,IGET(639))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2611,7 +2666,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(WASO(I,J,LL,1)0) THEN
! RDTPHS=1000./DTQ2
! DO J=JSTA,JEND
-! DO I=1,IM
+! DO I=ista,iend
! GRID1(I,J)=CPRATE(I,J)*RDTPHS
! GRID1(I,J)=SPVAL
! ENDDO
! ENDDO
! ID(1:25) = 0
-! CALL GRIBIT(IGET(249),LM,GRID1,IM,JM)
+! CALL GRIBIT(IGET(249),LM,GRIDista,iend,JM)
! ENDIF
!
! COMPOSITE RADAR REFLECTIVITY (maximum dBZ in each column)
@@ -2853,7 +2914,7 @@ SUBROUTINE MDLFLD
IF(IMP_PHYSICS /= 8 .and. IMP_PHYSICS /= 28) THEN
!$omp parallel do private(i,j,l)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = DBZmin
DO L=1,NINT(LMH(I,J))
GRID1(I,J) = MAX( GRID1(I,J), DBZ(I,J,L) )
@@ -2873,7 +2934,7 @@ SUBROUTINE MDLFLD
MODELNAME=='NMM' .and. gridtype=='E')THEN
!$omp parallel do private(i,j,l)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = DBZmin
DO L=1,NINT(LMH(I,J))
GRID1(I,J) = MAX( GRID1(I,J), REF_10CM(I,J,L) )
@@ -2883,7 +2944,7 @@ SUBROUTINE MDLFLD
ELSE
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = REFC_10CM(I,J)
ENDDO
ENDDO
@@ -2892,7 +2953,7 @@ SUBROUTINE MDLFLD
ELSE
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = refl(i,j)
ENDDO
ENDDO
@@ -2902,11 +2963,12 @@ SUBROUTINE MDLFLD
if(grib=="grib2") then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(252))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2917,7 +2979,7 @@ SUBROUTINE MDLFLD
! on emprical conversion factors (0.00344)
IF (IGET(581)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J)=0.0
DO L=1,NINT(LMH(I,J))
if(zint(i,j,l) < spval .and.zint(i,j,l+1)0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J)=DBZmin
DO L=1,NINT(LMH(I,J))
GRID1(I,J)=MAX( GRID1(I,J), DBZR(I,J,L) )
@@ -2954,11 +3017,12 @@ SUBROUTINE MDLFLD
if(grib=="grib2") then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(276))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2969,7 +3033,7 @@ SUBROUTINE MDLFLD
!
IF (IGET(277)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J)=DBZmin
DO L=1,NINT(LMH(I,J))
GRID1(I,J)=MAX( GRID1(I,J), DBZI(I,J,L) )
@@ -2979,11 +3043,12 @@ SUBROUTINE MDLFLD
if(grib=="grib2") then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(277))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2996,7 +3061,7 @@ SUBROUTINE MDLFLD
!
IF (IGET(278)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J)=DBZmin
DO L=1,NINT(LMH(I,J))
GRID1(I,J)=MAX( GRID1(I,J), DBZC(I,J,L) )
@@ -3006,11 +3071,12 @@ SUBROUTINE MDLFLD
if(grib=="grib2") then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(278))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3022,7 +3088,7 @@ SUBROUTINE MDLFLD
IF (IGET(426)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J)=0.0
DO L=1,NINT(LMH(I,J))
IF (DBZ(I,J,L)>=18.0) THEN
@@ -3035,11 +3101,12 @@ SUBROUTINE MDLFLD
if(grib=="grib2") then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(426))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3057,7 +3124,7 @@ SUBROUTINE MDLFLD
IF (IGET(768) > 0) THEN
IF(MODELNAME == 'RAPR' .AND. (IMP_PHYSICS == 8 .or. IMP_PHYSICS == 28)) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = -999.
DO L=1,NINT(LMH(I,J))
IF (REF_10CM(I,J,L)>=18.0) THEN
@@ -3086,7 +3153,7 @@ SUBROUTINE MDLFLD
ENDDO
ELSE
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = -999.
DO L=1,NINT(LMH(I,J))
IF (DBZ(I,J,L) >= 18.0) THEN
@@ -3100,11 +3167,12 @@ SUBROUTINE MDLFLD
if(grib=="grib2") then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(768))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3114,7 +3182,7 @@ SUBROUTINE MDLFLD
!
IF (IGET(769)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J)=0.0
DO L=1,NINT(LMH(I,J))
IF(QQR(I,J,L) 0) THEN
IF(MODELNAME == 'RAPR' .AND. (IMP_PHYSICS == 8 .or. IMP_PHYSICS == 28)) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = 0.0
DO L=1,NINT(LMH(I,J))
IF (REF_10CM(I,J,L) > -10.0 ) THEN
@@ -3163,7 +3232,7 @@ SUBROUTINE MDLFLD
ENDDO
ELSE
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = 0.0
DO L=1,NINT(LMH(I,J))
GRID1(I,J) = GRID1(I,J) + 0.00344 * &
@@ -3176,11 +3245,12 @@ SUBROUTINE MDLFLD
if(grib=="grib2") then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(770))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3196,7 +3266,7 @@ SUBROUTINE MDLFLD
!--- Needed values at 1st level above ground (Jin, '01; Ferrier, Feb '02)
!
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
LLMH=NINT(LMH(I,J))
Q1D(I,J)=Q(I,J,LLMH)
if(Q1D(I,J)<=0.) Q1D(I,J)=0. !tgs
@@ -3264,7 +3334,7 @@ SUBROUTINE MDLFLD
!
!-- Visibility using Warner-Stoelinga algorithm (Jin, '01)
!
- ii=im/2
+ ii=(ista+iend)/2
jj=(jsta+jend)/2
! print*,'Debug: Visbility ',Q1D(ii,jj),QW1(ii,jj),QR1(ii,jj)
! +,QI1(ii,jj) ,QS1(ii,jj),T1D(ii,jj),P1D(ii,jj)
@@ -3276,7 +3346,7 @@ SUBROUTINE MDLFLD
!
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(vis(i,j)/=spval.and.abs(vis(i,j))>24135.1)print*,'bad visbility' &
, i,j,Q1D(i,j),QW1(i,j),QR1(i,j),QI1(i,j) &
, QS1(i,j),T1D(i,j),P1D(i,j),vis(i,j)
@@ -3288,7 +3358,7 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(180))
fld_info(cfld)%lvl=LVLSXML(1,IGET(180))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
@@ -3298,7 +3368,7 @@ SUBROUTINE MDLFLD
IF (IGET(410)>0) THEN
CALL CALVIS_GSD(CZEN,VIS)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J)=VIS(I,J)
END DO
END DO
@@ -3306,7 +3376,7 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(410))
fld_info(cfld)%lvl=LVLSXML(1,IGET(410))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -3321,7 +3391,7 @@ SUBROUTINE MDLFLD
GRID1 = -20.0
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = REF1KM_10CM(I,J)
END DO
END DO
@@ -3329,7 +3399,7 @@ SUBROUTINE MDLFLD
ELSE
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = refl1km(I,J)
END DO
END DO
@@ -3340,7 +3410,7 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(748))
fld_info(cfld)%lvl=LVLSXML(1,IGET(748))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
@@ -3355,7 +3425,7 @@ SUBROUTINE MDLFLD
IF(MODELNAME == 'RAPR' .AND. (IMP_PHYSICS == 8 .or. IMP_PHYSICS == 28)) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = REF4KM_10CM(I,J)
END DO
END DO
@@ -3363,7 +3433,7 @@ SUBROUTINE MDLFLD
ELSE
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = refl4km(I,J)
END DO
END DO
@@ -3374,7 +3444,7 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(757))
fld_info(cfld)%lvl=LVLSXML(1,IGET(757))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
@@ -3382,7 +3452,7 @@ SUBROUTINE MDLFLD
IF (IGET(912)>0) THEN
Zm10c=spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
! dong handle missing value
if (slp(i,j) < spval) then
Zm10c(I,J)=ZMID(I,J,NINT(LMH(I,J)))
@@ -3406,7 +3476,7 @@ SUBROUTINE MDLFLD
IF(IMP_PHYSICS==8 .or. IMP_PHYSICS==28) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J)=spval
! dong handle missing value
if (slp(i,j) < spval) then
@@ -3417,7 +3487,7 @@ SUBROUTINE MDLFLD
ELSE
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J)=spval
! dong handle missing value
if (slp(i,j) < spval) then
@@ -3433,7 +3503,7 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(912))
fld_info(cfld)%lvl=LVLSXML(L,IGET(912))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -3450,14 +3520,14 @@ SUBROUTINE MDLFLD
IF (IGET(147)>0) THEN
!
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = EL0(I,J)
ENDDO
ENDDO
if(grib=="grib2") then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(147))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -3470,7 +3540,7 @@ SUBROUTINE MDLFLD
!$omp parallel do private(i,j,l)
DO L=1,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
EL(I,J,L) = D00
ENDDO
ENDDO
@@ -3481,7 +3551,7 @@ SUBROUTINE MDLFLD
ELSE IF(MODELNAME == 'NMM')THEN
DO L=1,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
EL(I,J,L)=EL_PBL(I,J,L) !NOW EL COMES OUT OF WRF NMM
ENDDO
ENDDO
@@ -3504,7 +3574,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = EL(I,J,LL)
ENDDO
ENDDO
@@ -3512,11 +3582,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(146))
fld_info(cfld)%lvl=LVLSXML(L,IGET(146))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3531,7 +3602,7 @@ SUBROUTINE MDLFLD
LL=LM-L+1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = RICHNO(I,J,LL)
ENDDO
ENDDO
@@ -3539,11 +3610,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(111))
fld_info(cfld)%lvl=LVLSXML(L,IGET(111))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3575,7 +3647,7 @@ SUBROUTINE MDLFLD
IF (IGET(289) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = PBLRI(I,J)
! PBLH(I,J) = PBLRI(I,J)
ENDDO
@@ -3583,11 +3655,12 @@ SUBROUTINE MDLFLD
if(grib=="grib2") then
Cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(289))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3600,7 +3673,7 @@ SUBROUTINE MDLFLD
IF ( (IGET(389) > 0) .OR. (IGET(454) > 0) ) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF(PBLRI(I,J) 0.)THEN
GRID1(I,J) = EGRID1(I,J)/EGRID2(I,J)
ELSE
@@ -3654,10 +3727,10 @@ SUBROUTINE MDLFLD
END DO
END DO
! compute v component now
- CALL H2V(EGRID3(1:im,JSTA_2L:JEND_2U),EGRID4)
+ CALL H2V(EGRID3(ista_2l:iend_2u,JSTA_2L:JEND_2U),EGRID4)
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
EGRID1(i,j) = 0.
EGRID2(i,j) = 0.
EGRID5(i,j) = 0.
@@ -3666,12 +3739,12 @@ SUBROUTINE MDLFLD
END DO
END DO
vert_loopv: DO L=LM,1,-1
- CALL H2V(ZMID(1:IM,JSTA_2L:JEND_2U,L), EGRID5)
- CALL H2V(PINT(1:IM,JSTA_2L:JEND_2U,L+1),EGRID6)
- CALL H2V(PINT(1:IM,JSTA_2L:JEND_2U,L), EGRID7)
+ CALL H2V(ZMID(ista_2l:iend_2u,JSTA_2L:JEND_2U,L), EGRID5)
+ CALL H2V(PINT(ista_2l:iend_2u,JSTA_2L:JEND_2U,L+1),EGRID6)
+ CALL H2V(PINT(ista_2l:iend_2u,JSTA_2L:JEND_2U,L), EGRID7)
HCOUNT=0
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
if (EGRID4(I,J) 0.)THEN
GRID2(I,J) = EGRID1(I,J)/EGRID2(I,J)
ELSE
@@ -3700,11 +3773,11 @@ SUBROUTINE MDLFLD
END DO
- CALL U2H(GRID1(1,JSTA_2L),EGRID1)
- CALL V2H(GRID2(1,JSTA_2L),EGRID2)
+ CALL U2H(GRID1(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),EGRID1)
+ CALL V2H(GRID2(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),EGRID2)
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
! EGRID1 is transport wind speed
! prevent floating overflow if either component is undefined
@@ -3726,20 +3799,22 @@ SUBROUTINE MDLFLD
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(389))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(390))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii=ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -3756,7 +3831,7 @@ SUBROUTINE MDLFLD
! write(0,*) 'IM is: ', IM
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
IF (PBLRI(I,J) /= SPVAL .and. EGRID3(I,J)/=SPVAL) then
GRID1(I,J) = EGRID3(I,J)*PBLRI(I,J)
@@ -3776,11 +3851,12 @@ SUBROUTINE MDLFLD
if(grib=='grib2') then
Cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(454))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3805,7 +3881,7 @@ SUBROUTINE MDLFLD
! if(me==0)print *,'dxm=',dxm
NSMOOTH = nint(5.*(13500./dxm))
do j = jsta_2l, jend_2u
- do i = 1, im
+ do i = ista_2l, iend_2u
GRID1(i,j)=PBLHGUST(i,j)
enddo
enddo
@@ -3814,14 +3890,14 @@ SUBROUTINE MDLFLD
CALL SMOOTH(GRID1,SDUMMY,IM,JM,0.5)
end do
do j = jsta_2l, jend_2u
- do i = 1, im
+ do i = ista_2l, iend_2u
PBLHGUST(i,j)=GRID1(i,j)
enddo
enddo
ENDIF
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
LPBL(I,J)=LM
if(ZINT(I,J,NINT(LMH(I,J))+1) 0) THEN
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
! if(GUST(I,J) > 200. .and. gust(i,j)0) THEN
- allocate(PBLREGIME(im,jsta_2l:jend_2u))
+ allocate(PBLREGIME(ista_2l:iend_2u,jsta_2l:jend_2u))
CALL CALPBLREGIME(PBLREGIME)
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J) = PBLREGIME(I,J)
ENDDO
ENDDO
if(grib=="grib2") then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(344))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3906,7 +3984,7 @@ SUBROUTINE MDLFLD
!
IF(IGET(400)>0)THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
!Initialed as 'undetected'. Nov. 17, 2014, B. ZHOU:
!changed from SPVAL to -5000. to distinguish missing grids and undetected
! GRID1(I,J) = SPVAL
@@ -3934,11 +4012,12 @@ SUBROUTINE MDLFLD
if(grib=="grib2") then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(400))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3947,7 +4026,7 @@ SUBROUTINE MDLFLD
!
! COMPUTE NCAR GTG turbulence
IF(IGET(464)>0 .or. IGET(467)>0 .or. IGET(470)>0)THEN
- i=IM/2
+ i=(ista+iend)/2
j=(jsta+jend)/2
! if(me == 0) print*,'sending input to GTG i,j,hgt,gust',i,j,ZINT(i,j,LP1),gust(i,j)
@@ -3957,10 +4036,10 @@ SUBROUTINE MDLFLD
call gtg_algo(im,jm,lm,jsta,jend,jsta_2L,jend_2U,&
uh,vh,wh,zmid,pmid,t,q,qqw,qqr,qqs,qqg,qqi,&
- ZINT(1:IM,JSTA_2L:JEND_2U,LP1),pblh,sfcshx,sfclhx,ustar,&
+ ZINT(ista_2l:iend_2u,JSTA_2L:JEND_2U,LP1),pblh,sfcshx,sfclhx,ustar,&
z0,gdlat,gdlon,dx,dy,u10,v10,GUST,avgprec,sm,sice,catedr,mwt,EL,gtg,RICHNO,item)
- i=IM/2
+ i=iend
j=jend ! 321,541
! print*,'GTG output: l,cat,mwt,gtg at',i,j
! do l=1,lm
@@ -3973,7 +4052,7 @@ SUBROUTINE MDLFLD
IF (LVLS(L,IGET(470))>0) THEN
LL=LM-L+1
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J)=gtg(i,j,LL)
ENDDO
ENDDO
@@ -3981,18 +4060,19 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(470))
fld_info(cfld)%lvl=LVLSXML(L,IGET(470))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J)=catedr(i,j,LL)
ENDDO
ENDDO
@@ -4000,17 +4080,18 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(471))
fld_info(cfld)%lvl=LVLSXML(L,IGET(471))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
GRID1(I,J)=mwt(i,j,LL)
ENDDO
ENDDO
@@ -4018,11 +4099,12 @@ SUBROUTINE MDLFLD
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(472))
fld_info(cfld)%lvl=LVLSXML(L,IGET(472))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4045,7 +4127,7 @@ SUBROUTINE MDLFLD
icing_gfip = spval
icing_gfis = spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ista,iend
if(debugprint .and. i==50 .and. j==jsta .and. me == 0) then
print*,'sending input to FIP ',i,j,lm,gdlat(i,j),gdlon(i,j), &
zint(i,j,lp1),cprate(i,j),prec(i,j),avgcprate(i,j),cape(i,j),cin(i,j)
@@ -4079,12 +4161,12 @@ SUBROUTINE MDLFLD
! do l=1,lm
! if(LVLS(L,IGET(450))>0 .or. LVLS(L,IGET(480))>0)then
! do j=jsta,jend
-! do i=1,im
+! do i=ista,iend
! grid1(i,j)=icing_gfip(i,j,l)
! end do
! end do
! ID(1:25) = 0
-! CALL GRIBIT(IGET(450),L,GRID1,IM,JM)
+! CALL GRIBIT(IGET(450),L,GRIDista,iend,JM)
! end if
! end do
ENDIF
diff --git a/sorc/ncep_post.fd/MISCLN.f b/sorc/ncep_post.fd/MISCLN.f
index 3bb9d9a96..9f23319e2 100644
--- a/sorc/ncep_post.fd/MISCLN.f
+++ b/sorc/ncep_post.fd/MISCLN.f
@@ -48,6 +48,7 @@
!! 21-09-01 E Colon - Correction to the effective layer top and
!! bottoma calculation which is only employed
!! for RTMA usage.
+!! 21-10-14 J MENG - 2D DECOMPOSITION
!!
!! USAGE: CALL MISCLN
!! INPUT ARGUMENT LIST:
@@ -95,7 +96,8 @@ SUBROUTINE MISCLN
rhmin, rgamog, tfrz, small, g
use ctlblk_mod, only: grib, cfld, fld_info, datapd, im, jsta, jend, jm, jsta_m, jend_m, &
nbnd, nbin_du, lm, htfd, spval, pthresh, nfd, petabnd, me,&
- jsta_2l, jend_2u, MODELNAME, SUBMODELNAME
+ jsta_2l, jend_2u, MODELNAME, SUBMODELNAME, &
+ ista, iend, ista_m, iend_M, ista_2l, iend_2u
use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml
use grib2_module, only: pset
use upp_physics, only: FPVSNEW,CALRH_PW,CALCAPE,CALCAPE2,TVIRTUAL
@@ -123,18 +125,18 @@ SUBROUTINE MISCLN
! DECLARE VARIABLES.
!
LOGICAL NORTH, FIELD1,FIELD2
- LOGICAL, dimension(IM,JSTA:JEND) :: DONE, DONE1
+ LOGICAL, dimension(ISTA:IEND,JSTA:JEND) :: DONE, DONE1
INTEGER, allocatable :: LVLBND(:,:,:),LB2(:,:)
! INTEGER LVLBND(IM,JM,NBND),LB2(IM,JM),LPBL(IM,JM)
real,dimension(im,jm) :: GRID1, GRID2
- real,dimension(im,jsta:jend) :: P1D, T1D, Q1D, U1D, V1D, SHR1D, Z1D, &
+ real,dimension(ista:iend,jsta:jend) :: P1D, T1D, Q1D, U1D, V1D, SHR1D, Z1D, &
RH1D, EGRID1, EGRID2, EGRID3, EGRID4, &
EGRID5, EGRID6, EGRID7, EGRID8, &
MLCAPE,MLCIN,MLLCL,MUCAPE,MUCIN,MUMIXR, &
FREEZELVL,MUQ1D,SLCL,THE,MAXTHE
- integer,dimension(im,jsta:jend) :: MAXTHEPOS
+ integer,dimension(ista:iend,jsta:jend) :: MAXTHEPOS
real, dimension(:,:,:),allocatable :: OMGBND, PWTBND, QCNVBND, &
PBND, TBND, QBND, &
UBND, VBND, RHBND, &
@@ -159,7 +161,7 @@ SUBROUTINE MISCLN
EFFUST,EFFVST,FSHR,HTSFC,&
ESRH
!
- integer I,J,jj,L,ITYPE,ISVALUE,LBND,ILVL,IFD,ITYPEFDLVL(NFD), &
+ integer I,J,ii,jj,L,ITYPE,ISVALUE,LBND,ILVL,IFD,ITYPEFDLVL(NFD), &
iget1, iget2, iget3, LLMH,imax,jmax,lmax
real DPBND,PKL1,PKU1,FAC1,FAC2,PL,TL,QL,QSAT,RHL,TVRL,TVRBLO, &
ES1,ES2,QS1,QS2,RH1,RH2,ZSF,DEPTH(2),work1,work2,work3, &
@@ -172,8 +174,8 @@ SUBROUTINE MISCLN
integer, allocatable :: ITYPEFDLVLCTL(:)
integer IE,IW,JN,JS,IVE(JM),IVW(JM),JVN,JVS
integer ISTART,ISTOP,JSTART,JSTOP,MIDCAL
- real dummy(IM,jsta:jend)
- integer idummy(IM,jsta:jend)
+ real dummy(ista:iend,jsta:jend)
+ integer idummy(ista:iend,jsta:jend)
! NEW VARIABLES USED FOR EFFECTIVE LAYER
INTEGER,dimension(:,:),allocatable :: EL_BASE, EL_TOPS
LOGICAL,dimension(:,:),allocatable :: FOUND_BASE, FOUND_TOPS
@@ -201,10 +203,10 @@ SUBROUTINE MISCLN
debugprint = .FALSE.
- allocate(USHR1(IM,jsta_2l:jend_2u),VSHR1(IM,jsta_2l:jend_2u), &
- USHR6(IM,jsta_2l:jend_2u),VSHR6(IM,jsta_2l:jend_2u))
- allocate(UST(IM,jsta_2l:jend_2u),VST(IM,jsta_2l:jend_2u), &
- HELI(IM,jsta_2l:jend_2u,2),FSHR(IM,jsta_2l:jend_2u))
+ allocate(USHR1(ista_2l:iend_2u,jsta_2l:jend_2u),VSHR1(ista_2l:iend_2u,jsta_2l:jend_2u), &
+ USHR6(ista_2l:iend_2u,jsta_2l:jend_2u),VSHR6(ista_2l:iend_2u,jsta_2l:jend_2u))
+ allocate(UST(ista_2l:iend_2u,jsta_2l:jend_2u),VST(ista_2l:iend_2u,jsta_2l:jend_2u), &
+ HELI(ista_2l:iend_2u,jsta_2l:jend_2u,2),FSHR(ista_2l:iend_2u,jsta_2l:jend_2u))
!
! HELICITY AND STORM MOTION.
iget1 = IGET(162)
@@ -221,7 +223,7 @@ SUBROUTINE MISCLN
IF (iget2 > 0) then
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = HELI(I,J,1)
ENDDO
ENDDO
@@ -229,11 +231,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(iget1)
fld_info(cfld)%lvl=LVLSXML(1,iget1)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -242,7 +245,7 @@ SUBROUTINE MISCLN
IF (iget3 > 0) then
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = HELI(I,J,2)
ENDDO
ENDDO
@@ -250,11 +253,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(iget1)
fld_info(cfld)%lvl=LVLSXML(2,iget1)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -263,18 +267,19 @@ SUBROUTINE MISCLN
IF (IGET(163) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = UST(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(163))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -282,18 +287,19 @@ SUBROUTINE MISCLN
IF (IGET(164) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = VST(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(164))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -303,15 +309,16 @@ SUBROUTINE MISCLN
! UPDRAFT HELICITY
if (IGET(427) > 0) THEN
- CALL CALUPDHEL(GRID1(1,jsta_2l))
+ CALL CALUPDHEL(GRID1(ista_2l:iend_2u,jsta_2l:jend_2u))
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(427))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -328,25 +335,26 @@ SUBROUTINE MISCLN
! 0-6 km shear magnitude
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
FSHR(I,J) = SQRT(USHR6(I,J)**2+VSHR6(I,J)**2)
ENDDO
ENDDO
IF(IGET(430) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = USHR1(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(430))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -354,18 +362,19 @@ SUBROUTINE MISCLN
IF(IGET(431) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = VSHR1(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(431))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -373,18 +382,19 @@ SUBROUTINE MISCLN
IF(IGET(432) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = USHR6(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(432))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -392,18 +402,19 @@ SUBROUTINE MISCLN
IF(IGET(433) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = VSHR6(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(433))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -429,7 +440,7 @@ SUBROUTINE MISCLN
! Chuang: Use GFS algorithm per Iredell's and DiMego's decision on unification
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(PMID(I,J,1) 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = P1D(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(054))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -475,16 +487,17 @@ SUBROUTINE MISCLN
! ICAO HEIGHT OF TROPOPAUSE
IF (IGET(399)>0) THEN
- CALL ICAOHEIGHT(P1D, GRID1(1,jsta))
+ CALL ICAOHEIGHT(P1D, GRID1(ista:iend,jsta:jend))
! print*,'sample TROPOPAUSE ICAO HEIGHTS',GRID1(im/2,(jsta+jend)/2)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(399))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -494,18 +507,19 @@ SUBROUTINE MISCLN
IF (IGET(177) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = Z1D(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(177))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -515,18 +529,19 @@ SUBROUTINE MISCLN
IF (IGET(055) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = T1D(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(055))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -534,15 +549,16 @@ SUBROUTINE MISCLN
!
! TROPOPAUSE POTENTIAL TEMPERATURE.
IF (IGET(108) > 0) THEN
- CALL CALPOT(P1D,T1D,GRID1(1,jsta))
+ CALL CALPOT(P1D,T1D,GRID1(ista:iend,jsta:jend))
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(108))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -552,7 +568,7 @@ SUBROUTINE MISCLN
IF ((IGET(056) > 0).OR.(IGET(057) > 0)) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=U1D(I,J)
GRID2(I,J)=V1D(I,J)
ENDDO
@@ -561,22 +577,24 @@ SUBROUTINE MISCLN
if(IGET(056)>0) then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(056))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
if(IGET(057)>0) then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(057))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -587,18 +605,19 @@ SUBROUTINE MISCLN
IF (IGET(058) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = SHR1D(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(058))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -612,11 +631,11 @@ SUBROUTINE MISCLN
IF ((IGET(173)>0) .OR. (IGET(174)>0) .OR. &
(IGET(175)>0) .OR. (IGET(176)>0)) THEN
- allocate(MAXWP(IM,jsta:jend), MAXWZ(IM,jsta:jend), &
- MAXWU(IM,jsta:jend), MAXWV(IM,jsta:jend),MAXWT(IM,jsta:jend))
+ allocate(MAXWP(ista:iend,jsta:jend), MAXWZ(ista:iend,jsta:jend), &
+ MAXWU(ista:iend,jsta:jend), MAXWV(ista:iend,jsta:jend),MAXWT(ista:iend,jsta:jend))
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
MAXWP(I,J)=SPVAL
MAXWZ(I,J)=SPVAL
MAXWU(I,J)=SPVAL
@@ -628,7 +647,7 @@ SUBROUTINE MISCLN
! Chuang: Use GFS algorithm per Iredell's and DiMego's decision on unification
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- loopI:DO I=1,IM
+ loopI:DO I=ISTA,IEND
DO L=1,LM
IF (ABS(PMID(I,J,L)-SPVAL)<=SMALL .OR. &
ABS(UH(I,J,L)-SPVAL)<=SMALL .OR. &
@@ -651,34 +670,36 @@ SUBROUTINE MISCLN
IF (IGET(173) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = MAXWP(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(173))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
ENDIF
! ICAO HEIGHT OF MAX WIND LEVEL
IF (IGET(398)>0) THEN
- CALL ICAOHEIGHT(MAXWP, GRID1(1,jsta))
+ CALL ICAOHEIGHT(MAXWP, GRID1(ista:iend,jsta:jend))
! print*,'sample MAX WIND ICAO HEIGHTS',GRID1(im/2,(jsta+jend)/2)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(398))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -687,18 +708,19 @@ SUBROUTINE MISCLN
IF (IGET(174) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = MAXWZ(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(174))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -708,7 +730,7 @@ SUBROUTINE MISCLN
IF ((IGET(175) > 0).OR.(IGET(176) > 0)) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = MAXWU(I,J)
GRID2(I,J) = MAXWV(I,J)
ENDDO
@@ -716,20 +738,22 @@ SUBROUTINE MISCLN
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(175))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(176))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -738,18 +762,19 @@ SUBROUTINE MISCLN
IF (IGET(314) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=MAXWT(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(314))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -767,10 +792,10 @@ SUBROUTINE MISCLN
(IGET(604)>0.or.IGET(605)>0).OR. &
(IGET(451)>0.or.IGET(578)>0).OR.IGET(580)>0 ) THEN
- ALLOCATE(T7D(IM,JSTA:JEND,NFD), Q7D(IM,JSTA:JEND,NFD), &
- U7D(IM,JSTA:JEND,NFD), V6D(IM,JSTA:JEND,NFD), &
- P7D(IM,JSTA:JEND,NFD), ICINGFD(IM,JSTA:JEND,NFD) &
- ,AERFD(IM,JSTA:JEND,NFD,NBIN_DU))
+ ALLOCATE(T7D(ISTA:IEND,JSTA:JEND,NFD), Q7D(ISTA:IEND,JSTA:JEND,NFD), &
+ U7D(ISTA:IEND,JSTA:JEND,NFD), V6D(ISTA:IEND,JSTA:JEND,NFD), &
+ P7D(ISTA:IEND,JSTA:JEND,NFD), ICINGFD(ISTA:IEND,JSTA:JEND,NFD),&
+ AERFD(ISTA:IEND,JSTA:JEND,NFD,NBIN_DU))
!
! DETERMINE WHETHER TO DO MSL OR AGL FD LEVELS
@@ -855,7 +880,7 @@ SUBROUTINE MISCLN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = T7D(I,J,IFD)
ENDDO
ENDDO
@@ -864,11 +889,12 @@ SUBROUTINE MISCLN
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET1)
fld_info(cfld)%lvl = LVLSXML(IFD,IGET1)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -878,11 +904,12 @@ SUBROUTINE MISCLN
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET2)
fld_info(cfld)%lvl = LVLSXML(IFD,IGET2)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -894,7 +921,7 @@ SUBROUTINE MISCLN
IF (IGET(911)>0) THEN
IF (LVLS(IFD,IGET(911))>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if ( T7D(I,J,IFD) > 600 ) then
GRID1(I,J)=SPVAL
else
@@ -908,7 +935,7 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(911))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(911))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -932,7 +959,7 @@ SUBROUTINE MISCLN
IF (work1 > 0 .or. work2 > 0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = Q7D(I,J,IFD)
ENDDO
ENDDO
@@ -941,11 +968,12 @@ SUBROUTINE MISCLN
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET1)
fld_info(cfld)%lvl = LVLSXML(IFD,IGET1)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -955,11 +983,12 @@ SUBROUTINE MISCLN
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET2)
fld_info(cfld)%lvl = LVLSXML(IFD,IGET2)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -984,7 +1013,7 @@ SUBROUTINE MISCLN
IF (work1 > 0 .or. work2 > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = P7D(I,J,IFD)
ENDDO
ENDDO
@@ -993,11 +1022,12 @@ SUBROUTINE MISCLN
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET1)
fld_info(cfld)%lvl = LVLSXML(IFD,IGET1)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1007,11 +1037,12 @@ SUBROUTINE MISCLN
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET2)
fld_info(cfld)%lvl = LVLSXML(IFD,IGET2)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1036,7 +1067,7 @@ SUBROUTINE MISCLN
IF (work1 > 0 .or. work2 > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = ICINGFD(I,J,IFD)
ENDDO
ENDDO
@@ -1045,11 +1076,12 @@ SUBROUTINE MISCLN
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET1)
fld_info(cfld)%lvl = LVLSXML(IFD,IGET1)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1059,11 +1091,12 @@ SUBROUTINE MISCLN
cfld = cfld + 1
fld_info(cfld)%ifld = IAVBLFLD(IGET2)
fld_info(cfld)%lvl = LVLSXML(IFD,IGET2)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1077,7 +1110,7 @@ SUBROUTINE MISCLN
IF (LVLS(IFD,IGET(601))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=AERFD(I,J,IFD,1)
ENDDO
ENDDO
@@ -1086,11 +1119,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(601))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(601))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1102,7 +1136,7 @@ SUBROUTINE MISCLN
IF (LVLS(IFD,IGET(602))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=AERFD(I,J,IFD,2)
ENDDO
ENDDO
@@ -1111,11 +1145,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(602))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(602))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1127,7 +1162,7 @@ SUBROUTINE MISCLN
IF (LVLS(IFD,IGET(603))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=AERFD(I,J,IFD,3)
ENDDO
ENDDO
@@ -1136,11 +1171,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(603))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(603))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1152,7 +1188,7 @@ SUBROUTINE MISCLN
IF (LVLS(IFD,IGET(604))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=AERFD(I,J,IFD,4)
ENDDO
ENDDO
@@ -1161,11 +1197,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(604))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(604))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1177,7 +1214,7 @@ SUBROUTINE MISCLN
IF (LVLS(IFD,IGET(605))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=AERFD(I,J,IFD,5)
ENDDO
ENDDO
@@ -1186,11 +1223,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(605))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(605))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1204,7 +1242,7 @@ SUBROUTINE MISCLN
IF ((IGET(060)>0).OR.(IGET(061)>0)) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=U7D(I,J,IFD)
GRID2(I,J)=V6D(I,J,IFD)
ENDDO
@@ -1215,11 +1253,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(060))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(060))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1231,11 +1270,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(061))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(061))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -1247,7 +1287,7 @@ SUBROUTINE MISCLN
IF ((IGET(576)>0).OR.(IGET(577)>0)) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = U7D(I,J,IFD)
GRID2(I,J) = V6D(I,J,IFD)
ENDDO
@@ -1258,11 +1298,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(576))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(576))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1274,11 +1315,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(577))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(577))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -1306,14 +1348,14 @@ SUBROUTINE MISCLN
allocate(HTFDCTL(NFDCTL))
HTFDCTL=pset%param(N)%level
! print *, "GTG 467 levels=",pset%param(N)%level
- allocate(GTGFD(IM,JSTA:JEND,NFDCTL))
+ allocate(GTGFD(ISTA:IEND,JSTA:JEND,NFDCTL))
call FDLVL_MASS(ITYPEFDLVLCTL,NFDCTL,HTFDCTL,GTG,GTGFD)
! print *, "GTG 467 Done GTGFD=",me,GTGFD(IM/2,jend,1:NFDCTL)
DO IFD = 1,NFDCTL
IF (LVLS(IFD,IGET(467))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=GTGFD(I,J,IFD)
ENDDO
ENDDO
@@ -1321,11 +1363,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(467))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(467))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1344,13 +1387,13 @@ SUBROUTINE MISCLN
if(allocated(HTFDCTL)) deallocate(HTFDCTL)
allocate(HTFDCTL(NFDCTL))
HTFDCTL=pset%param(N)%level
- allocate(CATFD(IM,JSTA:JEND,NFDCTL))
+ allocate(CATFD(ISTA:IEND,JSTA:JEND,NFDCTL))
call FDLVL_MASS(ITYPEFDLVLCTL,NFDCTL,HTFDCTL,catedr,CATFD)
DO IFD = 1,NFDCTL
IF (LVLS(IFD,IGET(468))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=CATFD(I,J,IFD)
ENDDO
ENDDO
@@ -1358,11 +1401,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(468))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(468))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1381,13 +1425,13 @@ SUBROUTINE MISCLN
if(allocated(HTFDCTL)) deallocate(HTFDCTL)
allocate(HTFDCTL(NFDCTL))
HTFDCTL=pset%param(N)%level
- allocate(MWTFD(IM,JSTA:JEND,NFDCTL))
+ allocate(MWTFD(ISTA:IEND,JSTA:JEND,NFDCTL))
call FDLVL_MASS(ITYPEFDLVLCTL,NFDCTL,HTFDCTL,MWT,MWTFD)
DO IFD = 1,NFDCTL
IF (LVLS(IFD,IGET(469))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=MWTFD(I,J,IFD)
ENDDO
ENDDO
@@ -1395,11 +1439,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(469))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(469))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1426,7 +1471,7 @@ SUBROUTINE MISCLN
IF (IGET(062)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=Z1D(I,J)
IF (SUBMODELNAME == 'RTMA') THEN
FREEZELVL(I,J)=GRID1(I,J)
@@ -1437,11 +1482,12 @@ SUBROUTINE MISCLN
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(062))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1451,20 +1497,21 @@ SUBROUTINE MISCLN
IF (IGET(063)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RH1D(I,J)
ENDDO
ENDDO
- CALL SCLFLD(GRID1,H100,IM,JM)
+ CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM)
CALL BOUND(GRID1,H1,H100)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(063))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1474,18 +1521,19 @@ SUBROUTINE MISCLN
IF (IGET(753)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = P1D(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(753))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1500,7 +1548,7 @@ SUBROUTINE MISCLN
IF (IGET(165)>0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=Z1D(I,J)
ENDDO
ENDDO
@@ -1508,11 +1556,12 @@ SUBROUTINE MISCLN
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(165))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1523,7 +1572,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(RH1D(I,J) < spval) GRID1(I,J)=RH1D(I,J)*100.
ENDDO
ENDDO
@@ -1531,11 +1580,12 @@ SUBROUTINE MISCLN
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(350))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1545,18 +1595,19 @@ SUBROUTINE MISCLN
IF (IGET(756)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = P1D(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(756))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1573,7 +1624,7 @@ SUBROUTINE MISCLN
IF (IGET(776)>0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=Z1D(I,J)
ENDDO
ENDDO
@@ -1581,11 +1632,12 @@ SUBROUTINE MISCLN
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(776))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1596,7 +1648,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(RH1D(I,J) < spval) GRID1(I,J)=RH1D(I,J)*100.
ENDDO
ENDDO
@@ -1604,11 +1656,12 @@ SUBROUTINE MISCLN
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(777))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1618,18 +1671,19 @@ SUBROUTINE MISCLN
IF (IGET(778)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=P1D(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(778))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1646,7 +1700,7 @@ SUBROUTINE MISCLN
IF (IGET(779)>0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=Z1D(I,J)
ENDDO
ENDDO
@@ -1654,11 +1708,12 @@ SUBROUTINE MISCLN
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(779))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1669,7 +1724,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(RH1D(I,J) < spval) GRID1(I,J)=RH1D(I,J)*100.
ENDDO
ENDDO
@@ -1677,11 +1732,12 @@ SUBROUTINE MISCLN
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(780))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1691,18 +1747,19 @@ SUBROUTINE MISCLN
IF (IGET(781)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=P1D(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(781))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1710,10 +1767,10 @@ SUBROUTINE MISCLN
ENDIF
!
- allocate(PBND(IM,jsta:jend,NBND), TBND(IM,jsta:jend,NBND), &
- QBND(IM,jsta:jend,NBND), UBND(IM,jsta:jend,NBND), &
- VBND(IM,jsta:jend,NBND), RHBND(IM,jsta:jend,NBND), &
- WBND(IM,jsta:jend,NBND))
+ allocate(PBND(ista:iend,jsta:jend,NBND), TBND(ista:iend,jsta:jend,NBND), &
+ QBND(ista:iend,jsta:jend,NBND), UBND(ista:iend,jsta:jend,NBND), &
+ VBND(ista:iend,jsta:jend,NBND), RHBND(ista:iend,jsta:jend,NBND), &
+ WBND(ista:iend,jsta:jend,NBND))
!
! ***BLOCK 5: BOUNDARY LAYER FIELDS.
@@ -1733,9 +1790,9 @@ SUBROUTINE MISCLN
(IGET(096)>0).OR.(IGET(097)>0).OR. &
(IGET(098)>0).OR.(IGET(221)>0) ) THEN
!
- allocate(OMGBND(IM,jsta:jend,NBND),PWTBND(IM,jsta:jend,NBND), &
- QCNVBND(IM,jsta:jend,NBND),LVLBND(IM,jsta:jend,NBND), &
- LB2(IM,jsta:jend))
+ allocate(OMGBND(ista:iend,jsta:jend,NBND),PWTBND(ista:iend,jsta:jend,NBND), &
+ QCNVBND(ista:iend,jsta:jend,NBND),LVLBND(ista:iend,jsta:jend,NBND), &
+ LB2(ista:iend,jsta:jend))
! COMPUTE ETA BOUNDARY LAYER FIELDS.
CALL BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, &
@@ -1743,7 +1800,7 @@ SUBROUTINE MISCLN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EGRID2(i,j) = SPVAL
ENDDO
ENDDO
@@ -1757,7 +1814,7 @@ SUBROUTINE MISCLN
IF (LVLS(LBND,IGET(067))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = PBND(I,J,LBND)
ENDDO
ENDDO
@@ -1765,11 +1822,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(067))
fld_info(cfld)%lvl=LVLSXML(LBND,IGET(067))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1781,7 +1839,7 @@ SUBROUTINE MISCLN
IF (LVLS(LBND,IGET(068))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=TBND(I,J,LBND)
ENDDO
ENDDO
@@ -1789,11 +1847,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(068))
fld_info(cfld)%lvl=LVLSXML(LBND,IGET(068))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1803,16 +1862,17 @@ SUBROUTINE MISCLN
! BOUNDARY LAYER POTENTIAL TEMPERATURE.
IF (IGET(069)>0) THEN
IF (LVLS(LBND,IGET(069))>0) THEN
- CALL CALPOT(PBND(1,jsta,LBND),TBND(1,jsta,LBND),GRID1(1,jsta))
+ CALL CALPOT(PBND(ista,jsta,LBND),TBND(ista,jsta,LBND),GRID1(ista:iend,jsta:jend))
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(069))
fld_info(cfld)%lvl=LVLSXML(IFD,IGET(069))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1824,21 +1884,22 @@ SUBROUTINE MISCLN
IF (LVLS(LBND,IGET(072))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=RHBND(I,J,LBND)
ENDDO
ENDDO
- CALL SCLFLD(GRID1,H100,IM,JM)
+ CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM)
CALL BOUND(GRID1,H1,H100)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%lvl=LVLSXML(LBND,IGET(072))
fld_info(cfld)%ifld=IAVBLFLD(IGET(072))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1848,17 +1909,18 @@ SUBROUTINE MISCLN
! BOUNDARY LAYER DEWPOINT TEMPERATURE.
IF (IGET(070)>0) THEN
IF (LVLS(LBND,IGET(070))>0) THEN
- CALL CALDWP(PBND(1,jsta,LBND), QBND(1,jsta,LBND), &
- GRID1(1,jsta), TBND(1,jsta,LBND))
+ CALL CALDWP(PBND(ista:iend,jsta:jend,LBND), QBND(ista:iend,jsta:jend,LBND), &
+ GRID1(ista:iend,jsta:jend), TBND(ista:iend,jsta:jend,LBND))
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(070))
fld_info(cfld)%lvl=LVLSXML(LBND,IGET(070))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1870,7 +1932,7 @@ SUBROUTINE MISCLN
IF (LVLS(LBND,IGET(071))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=QBND(I,J,LBND)
ENDDO
ENDDO
@@ -1879,11 +1941,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(071))
fld_info(cfld)%lvl=LVLSXML(LBND,IGET(071))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1895,7 +1958,7 @@ SUBROUTINE MISCLN
IF (LVLS(LBND,IGET(088))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = QCNVBND(I,J,LBND)
ENDDO
ENDDO
@@ -1903,11 +1966,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(088))
fld_info(cfld)%lvl=LVLSXML(LBND,IGET(088))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1929,7 +1993,7 @@ SUBROUTINE MISCLN
IF(FIELD1.OR.FIELD2)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = UBND(I,J,LBND)
GRID2(I,J) = VBND(I,J,LBND)
ENDDO
@@ -1941,11 +2005,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(073))
fld_info(cfld)%lvl=LVLSXML(LBND,IGET(073))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1957,11 +2022,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(074))
fld_info(cfld)%lvl=LVLSXML(LBND,IGET(074))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -1974,7 +2040,7 @@ SUBROUTINE MISCLN
IF (LVLS(LBND,IGET(090))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = OMGBND(I,J,LBND)
ENDDO
ENDDO
@@ -1982,11 +2048,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(090))
fld_info(cfld)%lvl=LVLSXML(LBND,IGET(090))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endiF
@@ -1998,7 +2065,7 @@ SUBROUTINE MISCLN
IF (LVLS(LBND,IGET(089))>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = PWTBND(I,J,LBND)
ENDDO
ENDDO
@@ -2007,11 +2074,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(089))
fld_info(cfld)%lvl=LVLSXML(LBND,IGET(089))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2020,19 +2088,20 @@ SUBROUTINE MISCLN
!
! BOUNDARY LAYER LIFTED INDEX.
IF (IGET(075)>0 .OR. IGET(031)>0 .OR. IGET(573)>0) THEN
- CALL OTLFT(PBND(1,jsta,LBND),TBND(1,jsta,LBND), &
- QBND(1,jsta,LBND),GRID1(1,jsta))
+ CALL OTLFT(PBND(ista,jsta,LBND),TBND(ista,jsta,LBND), &
+ QBND(ista,jsta,LBND),GRID1(ista:iend,jsta:jend))
IF(IGET(075)>0)THEN
IF (LVLS(LBND,IGET(075))>0) THEN
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(075))
fld_info(cfld)%lvl=LVLSXML(LBND,IGET(075))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2041,7 +2110,7 @@ SUBROUTINE MISCLN
IF(IGET(031)>0 .or. IGET(573)>0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EGRID2(I,J) = MIN(EGRID2(I,J),GRID1(I,J))
END DO
END DO
@@ -2073,7 +2142,7 @@ SUBROUTINE MISCLN
! 50 CONTINUE
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=EGRID2(I,J)
ENDDO
ENDDO
@@ -2083,7 +2152,7 @@ SUBROUTINE MISCLN
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(031))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
endif
@@ -2091,11 +2160,12 @@ SUBROUTINE MISCLN
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(573))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2132,18 +2202,18 @@ SUBROUTINE MISCLN
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EGRID1(I,J) = -H99999
EGRID2(I,J) = -H99999
ENDDO
ENDDO
!
DO 80 LBND = 1,NBND
- CALL CALTHTE(PBND(1,jsta,LBND),TBND(1,jsta,LBND), &
- QBND(1,jsta,LBND),EGRID1)
+ CALL CALTHTE(PBND(ista,jsta,LBND),TBND(ista,jsta,LBND), &
+ QBND(ista,jsta,LBND),EGRID1)
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (EGRID1(I,J) > EGRID2(I,J)) THEN
EGRID2(I,J) = EGRID1(I,J)
LB2(I,J) = LVLBND(I,J,LBND)
@@ -2164,7 +2234,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J)
ENDDO
ENDDO
@@ -2173,11 +2243,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(566))
fld_info(cfld)%lvl=LVLSXML(1,IGET(566))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2188,7 +2259,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J)
ENDDO
ENDDO
@@ -2197,7 +2268,7 @@ SUBROUTINE MISCLN
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J)
ENDDO
ENDDO
@@ -2206,11 +2277,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(567))
fld_info(cfld)%lvl=LVLSXML(1,IGET(567))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2222,18 +2294,19 @@ SUBROUTINE MISCLN
IF(IGET(221) > 0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = PBLH(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(221))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2242,24 +2315,25 @@ SUBROUTINE MISCLN
! EGRID1 IS LCL PRESSURE. EGRID2 IS LCL HEIGHT.
!
IF ( (IGET(109)>0).OR.(IGET(110)>0) ) THEN
- CALL CALLCL(PBND(1,jsta,1),TBND(1,jsta,1), &
- QBND(1,jsta,1),EGRID1,EGRID2)
+ CALL CALLCL(PBND(ista,jsta,1),TBND(ista,jsta,1), &
+ QBND(ista,jsta,1),EGRID1,EGRID2)
IF (IGET(109)>0) THEN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(TBND(I,J,1) < spval) GRID1(I,J) = EGRID2(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(109))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2268,18 +2342,19 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(TBND(I,J,1) < spval) GRID1(I,J) = EGRID1(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(110))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2294,15 +2369,15 @@ SUBROUTINE MISCLN
(IGET(096)>0).OR.(IGET(097)>0).OR. &
(IGET(098)>0) ) THEN
- allocate(T78483(im,jsta:jend), T89671(im,jsta:jend), &
- P78483(im,jsta:jend), P89671(im,jsta:jend))
+ allocate(T78483(ista:iend,jsta:jend), T89671(ista:iend,jsta:jend), &
+ P78483(ista:iend,jsta:jend), P89671(ista:iend,jsta:jend))
!
! COMPUTE SIGMA 0.89671 AND 0.78483 TEMPERATURES
! INTERPOLATE LINEAR IN LOG P
IF (IGET(097)>0.OR.IGET(098)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
P78483(I,J) = LOG(PINT(I,J,NINT(LMH(I,J)))*0.78483)
P89671(I,J) = LOG(PINT(I,J,NINT(LMH(I,J)))*0.89671)
ENDDO
@@ -2312,7 +2387,7 @@ SUBROUTINE MISCLN
!!$omp parallel do private(fac1,fac2,pkl1,pku1,t78483,t89671)
DO L=2,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
PKL1=0.5*(ALPINT(I,J,L)+ALPINT(I,J,L+1))
PKU1=0.5*(ALPINT(I,J,L)+ALPINT(I,J,L-1))
! IF(I==1 .AND. J==1)PRINT*,'L,P89671,PKL1,PKU1= ', &
@@ -2336,7 +2411,7 @@ SUBROUTINE MISCLN
! print*,'done(1,1)= ',done(1,1)
!$omp parallel do private(i,j,pl,tl,ql,qsat,rhl)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(.NOT. DONE(I,J)) THEN
PL = PINT(I,J,LM-1)
TL = 0.5*(T(I,J,LM-2)+T(I,J,LM-1))
@@ -2406,7 +2481,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T(I,J,LM) < spval) GRID1(I,J) = T89671(I,J)
! IF(T89671(I,J)>350.)PRINT*,'LARGE T89671 ', &
! I,J,T89671(I,J)
@@ -2416,11 +2491,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(097))
fld_info(cfld)%lvl=LVLSXML(1,IGET(097))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2431,7 +2507,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T(I,J,LM) < spval) GRID1(I,J) = T78483(I,J)
ENDDO
ENDDO
@@ -2439,11 +2515,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(098))
fld_info(cfld)%lvl=LVLSXML(1,IGET(098))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2465,18 +2542,19 @@ SUBROUTINE MISCLN
IF (IGET(091)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = PBND(I,J,1)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(091))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2486,7 +2564,7 @@ SUBROUTINE MISCLN
IF (IGET(092)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = TBND(I,J,1)
ENDDO
ENDDO
@@ -2494,11 +2572,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(092))
fld_info(cfld)%lvl=LVLSXML(1,IGET(092))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2508,7 +2587,7 @@ SUBROUTINE MISCLN
IF (IGET(093)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = QBND(I,J,1)
ENDDO
ENDDO
@@ -2517,11 +2596,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(093))
fld_info(cfld)%lvl=LVLSXML(1,IGET(093))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2531,21 +2611,22 @@ SUBROUTINE MISCLN
IF (IGET(094)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RHBND(I,J,1)
ENDDO
ENDDO
- CALL SCLFLD(GRID1,H100,IM,JM)
+ CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM)
CALL BOUND(GRID1,H1,H100)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(094))
fld_info(cfld)%lvl=LVLSXML(1,IGET(094))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2555,7 +2636,7 @@ SUBROUTINE MISCLN
IF ((IGET(095)>0).OR.(IGET(096)>0)) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = UBND(I,J,1)
GRID2(I,J) = VBND(I,J,1)
ENDDO
@@ -2565,11 +2646,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(095))
fld_info(cfld)%lvl=LVLSXML(1,IGET(095))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2579,11 +2661,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(096))
fld_info(cfld)%lvl=LVLSXML(1,IGET(096))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -2609,29 +2692,30 @@ SUBROUTINE MISCLN
!
IF ( (IGET(066)>0).OR.(IGET(081)>0).OR. &
(IGET(082)>0).OR.(IGET(104)>0) ) THEN
- allocate(RH3310(IM,jsta:jend),RH6610(IM,jsta:jend), &
- RH3366(IM,jsta:jend),PW3310(IM,jsta:jend))
+ allocate(RH3310(ista:iend,jsta:jend),RH6610(ista:iend,jsta:jend), &
+ RH3366(ista:iend,jsta:jend),PW3310(ista:iend,jsta:jend))
CALL LFMFLD(RH3310,RH6610,RH3366,PW3310)
!
! SIGMA 0.33-1.00 MEAN RELATIVE HUMIIDITY.
IF (IGET(066)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RH3310(I,J)
ENDDO
ENDDO
- CALL SCLFLD(GRID1,H100,IM,JM)
+ CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM)
CALL BOUND(GRID1,H1,H100)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(066))
fld_info(cfld)%lvl=LVLSXML(1,IGET(066))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
! print *,'in miscln,RH0.33-1.0,cfld=',cfld,'fld=', &
@@ -2643,21 +2727,22 @@ SUBROUTINE MISCLN
IF (IGET(081)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RH6610(I,J)
ENDDO
ENDDO
- CALL SCLFLD(GRID1,H100,IM,JM)
+ CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM)
CALL BOUND(GRID1,H1,H100)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(081))
fld_info(cfld)%lvl=LVLSXML(1,IGET(081))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2667,21 +2752,22 @@ SUBROUTINE MISCLN
IF (IGET(082)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RH3366(I,J)
ENDDO
ENDDO
- CALL SCLFLD(GRID1,H100,IM,JM)
+ CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM)
CALL BOUND(GRID1,H1,H100)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(082))
fld_info(cfld)%lvl=LVLSXML(1,IGET(082))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2691,7 +2777,7 @@ SUBROUTINE MISCLN
IF (IGET(104)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = PW3310(I,J)
ENDDO
ENDDO
@@ -2700,11 +2786,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(104))
fld_info(cfld)%lvl=LVLSXML(1,IGET(104))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2717,9 +2804,9 @@ SUBROUTINE MISCLN
IF ( (IGET(099)>0).OR.(IGET(100)>0).OR. &
(IGET(101)>0).OR.(IGET(102)>0).OR. &
(IGET(103)>0) ) THEN
- allocate(RH4710(IM,jsta_2l:jend_2u),RH4796(IM,jsta_2l:jend_2u), &
- RH1847(IM,jsta_2l:jend_2u))
- allocate(RH8498(IM,jsta_2l:jend_2u),QM8510(IM,jsta_2l:jend_2u))
+ allocate(RH4710(ista_2l:iend_2u,jsta_2l:jend_2u),RH4796(ista_2l:iend_2u,jsta_2l:jend_2u), &
+ RH1847(ista_2l:iend_2u,jsta_2l:jend_2u))
+ allocate(RH8498(ista_2l:iend_2u,jsta_2l:jend_2u),QM8510(ista_2l:iend_2u,jsta_2l:jend_2u))
CALL NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510)
!
@@ -2727,21 +2814,22 @@ SUBROUTINE MISCLN
IF (IGET(099)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RH4710(I,J)
ENDDO
ENDDO
- CALL SCLFLD(GRID1,H100,IM,JM)
+ CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM)
CALL BOUND(GRID1,H1,H100)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(099))
fld_info(cfld)%lvl=LVLSXML(1,IGET(099))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2751,21 +2839,22 @@ SUBROUTINE MISCLN
IF (IGET(100)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RH4796(I,J)
ENDDO
ENDDO
- CALL SCLFLD(GRID1,H100,IM,JM)
+ CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM)
CALL BOUND(GRID1,H1,H100)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(100))
fld_info(cfld)%lvl=LVLSXML(1,IGET(100))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2775,21 +2864,22 @@ SUBROUTINE MISCLN
IF (IGET(101)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RH1847(I,J)
ENDDO
ENDDO
- CALL SCLFLD(GRID1,H100,IM,JM)
+ CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM)
CALL BOUND(GRID1,H1,H100)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(101))
fld_info(cfld)%lvl=LVLSXML(1,IGET(101))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2799,21 +2889,22 @@ SUBROUTINE MISCLN
IF (IGET(102)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RH8498(I,J)
ENDDO
ENDDO
- CALL SCLFLD(GRID1,H100,IM,JM)
+ CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM)
CALL BOUND(GRID1,H1,H100)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(102))
fld_info(cfld)%lvl=LVLSXML(1,IGET(102))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2825,7 +2916,7 @@ SUBROUTINE MISCLN
! CONVERT TO DIVERGENCE FOR GRIB
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(QM8510(I,J) < spval) GRID1(I,J) = -1.0*QM8510(I,J)
ENDDO
ENDDO
@@ -2833,11 +2924,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(103))
fld_info(cfld)%lvl=LVLSXML(1,IGET(103))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2849,8 +2941,8 @@ SUBROUTINE MISCLN
IF ( (IGET(318)>0).OR.(IGET(319)>0).OR. &
(IGET(320)>0))THEN
- allocate(RH4410(IM,jsta:jend),RH7294(IM,jsta:jend), &
- RH4472(IM,jsta:jend),RH3310(IM,jsta:jend))
+ allocate(RH4410(ista:iend,jsta:jend),RH7294(ista:iend,jsta:jend), &
+ RH4472(ista:iend,jsta:jend),RH3310(ista:iend,jsta:jend))
CALL LFMFLD_GFS(RH4410,RH7294,RH4472,RH3310)
!
! SIGMA 0.44-1.00 MEAN RELATIVE HUMIIDITY.
@@ -2858,7 +2950,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(RH4410(I,J) < spval) GRID1(I,J) = RH4410(I,J)*100.
ENDDO
ENDDO
@@ -2867,11 +2959,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(318))
fld_info(cfld)%lvl=LVLSXML(1,IGET(318))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2882,7 +2975,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(RH7294(I,J) < spval) GRID1(I,J) = RH7294(I,J)*100.
ENDDO
ENDDO
@@ -2891,11 +2984,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(319))
fld_info(cfld)%lvl=LVLSXML(1,IGET(319))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2906,7 +3000,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(RH4472(I,J) < spval) GRID1(I,J)=RH4472(I,J)*100.
ENDDO
ENDDO
@@ -2915,11 +3009,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(320))
fld_info(cfld)%lvl=LVLSXML(1,IGET(320))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2933,7 +3028,7 @@ SUBROUTINE MISCLN
(IGET(325)>0).OR.(IGET(326)>0)) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EGRID2(I,J) = 0.995*PINT(I,J,LM+1)
EGRID1(I,J) = LOG(PMID(I,J,LM)/EGRID2(I,J)) &
/ LOG(PMID(I,J,LM)/PMID(I,J,LM-1))
@@ -2954,7 +3049,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T(I,J,LM)0) THEN
GRID1=spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) GRID1(I,J)=EGRID2(I,J)
IF (SUBMODELNAME == 'RTMA') MLLCL(I,J) = GRID1(I,J)
ENDDO
@@ -3267,7 +3370,7 @@ SUBROUTINE MISCLN
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EGRID1(I,J) = -H99999
EGRID2(I,J) = -H99999
ENDDO
@@ -3281,7 +3384,7 @@ SUBROUTINE MISCLN
GRID1 = spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) THEN
GRID1(I,J) = EGRID1(I,J)
IF (SUBMODELNAME == 'RTMA') MUCAPE(I,J)=GRID1(I,J)
@@ -3296,11 +3399,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(584))
fld_info(cfld)%lvl=LVLSXML(1,IGET(584))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3312,13 +3416,13 @@ SUBROUTINE MISCLN
GRID1 = spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J)
ENDDO
ENDDO
CALL BOUND(GRID1,D00,H99999)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) THEN
GRID1(I,J) = - GRID1(I,J)
IF (SUBMODELNAME == 'RTMA')THEN
@@ -3332,11 +3436,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(585))
fld_info(cfld)%lvl=LVLSXML(1,IGET(585))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3348,7 +3453,7 @@ SUBROUTINE MISCLN
GRID1 = spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) GRID1(I,J) = EGRID4(I,J)
ENDDO
ENDDO
@@ -3356,11 +3461,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(443))
fld_info(cfld)%lvl=LVLSXML(1,IGET(443))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3368,7 +3474,7 @@ SUBROUTINE MISCLN
!Equilibrium Temperature
IF (IGET(982)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = TEQL(I,J)
ENDDO
ENDDO
@@ -3376,11 +3482,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(982))
fld_info(cfld)%lvl=LVLSXML(1,IGET(982))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3393,7 +3500,7 @@ SUBROUTINE MISCLN
GRID1 = spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) GRID1(I,J) = EGRID3(I,J)
ENDDO
ENDDO
@@ -3404,11 +3511,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(246))
fld_info(cfld)%lvl=LVLSXML(1,IGET(246))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3419,7 +3527,7 @@ SUBROUTINE MISCLN
GRID1 = spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(CPRATE(I,J) < spval) THEN
IF (CPRATE(I,J) > PTHRESH) THEN
GRID1(I,J) = EGRID5(I,J)
@@ -3434,11 +3542,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(444))
fld_info(cfld)%lvl=LVLSXML(1,IGET(444))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3451,13 +3560,13 @@ SUBROUTINE MISCLN
! --- Effective (inflow) Layer (EL)
!
- ALLOCATE(EL_BASE(IM,JSTA_2L:JEND_2U))
- ALLOCATE(EL_TOPS(IM,JSTA_2L:JEND_2U))
- ALLOCATE(FOUND_BASE(IM,JSTA_2L:JEND_2U))
- ALLOCATE(FOUND_TOPS(IM,JSTA_2L:JEND_2U))
+ ALLOCATE(EL_BASE(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U))
+ ALLOCATE(EL_TOPS(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U))
+ ALLOCATE(FOUND_BASE(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U))
+ ALLOCATE(FOUND_TOPS(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U))
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EL_BASE(I,J) = LM
EL_TOPS(I,J) = LM
FOUND_BASE(I,J) = .FALSE.
@@ -3475,7 +3584,7 @@ SUBROUTINE MISCLN
! SET AIR PARCELS FOR LEVEL L
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EGRID1(I,J) = -H99999
EGRID2(I,J) = -H99999
IDUMMY(I,J) = 0
@@ -3494,7 +3603,7 @@ SUBROUTINE MISCLN
!--- CHECK CAPE/CIN OF EACH AIR PARCELS WITH EL CRITERIA
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF ( .NOT. FOUND_BASE(I,J) ) THEN
IF ( EGRID1(I,J) >= 100. .AND. EGRID2(I,J) >= -250. ) THEN
EL_BASE(I,J) = L
@@ -3539,7 +3648,7 @@ SUBROUTINE MISCLN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IREC = IREC + 1
IREC2 = IREC2 + 1
WRITE(IUNIT,'(1x,I6,2x,I6,2(2x,I6,2x,F12.3))') I, J, &
@@ -3559,7 +3668,7 @@ SUBROUTINE MISCLN
!
! CAPE AND CINS 0-3KM, FOLLOW ML PROCEDURE WITH HEIGHT 0-3KM
!
- IF (MODELNAME == 'RAPR') THEN
+ IF (MODELNAME == 'RAPR') THEN
FIELD1=.FALSE.
FIELD2=.FALSE.
@@ -3580,7 +3689,8 @@ SUBROUTINE MISCLN
ELSE !FV3R and others
FIELD1=.TRUE.
FIELD2=.TRUE.
-! Wm Lewis 2 JUN 2022: Necessary that FIELD1/FIELD2=.FALSE. FOR GOES-16/17/18
+! Wm Lewis 2 JUN 2022: Necessary that FIELD1/FIELD2=.FALSE. FOR
+! GOES-16/17/18
IF((IGET(927)>0).OR.(IGET(928)>0).OR.(IGET(929)>0).OR.(IGET(930)>0).OR. &
(IGET(931)>0).OR.(IGET(932)>0).OR.(IGET(933)>0).OR.(IGET(934)>0).OR. &
(IGET(935)>0).OR.(IGET(936)>0).OR.(IGET(937)>0).OR.(IGET(938)>0).OR. &
@@ -3600,7 +3710,7 @@ SUBROUTINE MISCLN
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EGRID1(I,J) = -H99999
EGRID2(I,J) = -H99999
EGRID3(I,J) = -H99999
@@ -3634,7 +3744,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J)
ENDDO
ENDDO
@@ -3643,11 +3753,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(950))
fld_info(cfld)%lvl=LVLSXML(1,IGET(950))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3658,7 +3769,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J)
ENDDO
ENDDO
@@ -3667,7 +3778,7 @@ SUBROUTINE MISCLN
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J)
ENDDO
ENDDO
@@ -3676,11 +3787,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(951))
fld_info(cfld)%lvl=LVLSXML(1,IGET(951))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3692,7 +3804,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) GRID1(I,J) = EGRID3(I,J)
ENDDO
ENDDO
@@ -3701,11 +3813,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(952))
fld_info(cfld)%lvl=LVLSXML(1,IGET(952))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3714,10 +3827,10 @@ SUBROUTINE MISCLN
! EFFECTIVE STORM RELATIVE HELICITY AND STORM MOTION.
- allocate(UST(IM,jsta_2l:jend_2u),VST(IM,jsta_2l:jend_2u), &
- HELI(IM,jsta_2l:jend_2u,2))
- allocate(LLOW(IM,jsta_2l:jend_2u),LUPP(IM,jsta_2l:jend_2u), &
- CANGLE(IM,jsta_2l:jend_2u))
+ allocate(UST(ista_2l:iend_2u,jsta_2l:jend_2u),VST(ista_2l:iend_2u,jsta_2l:jend_2u), &
+ HELI(ista_2l:iend_2u,jsta_2l:jend_2u,2))
+ allocate(LLOW(ista_2l:iend_2u,jsta_2l:jend_2u),LUPP(ista_2l:iend_2u,jsta_2l:jend_2u), &
+ CANGLE(ista_2l:iend_2u,jsta_2l:jend_2u))
iget1 = IGET(953)
iget2 = -1
@@ -3735,7 +3848,7 @@ SUBROUTINE MISCLN
!RELATED VARIABLES
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
LLOW(I,J) = EL_BASE(I,J)
LUPP(I,J) = EL_TOPS(I,J)
ENDDO
@@ -3743,7 +3856,7 @@ SUBROUTINE MISCLN
ELSE
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
LLOW(I,J) = INT(EGRID4(I,J))
LUPP(I,J) = INT(EGRID5(I,J))
ENDDO
@@ -3760,7 +3873,7 @@ SUBROUTINE MISCLN
IREC=0
OPEN(IUNIT,FILE=TRIM(ADJUSTL(EFFL_FNAME)),FORM='FORMATTED')
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IREC = IREC + 1
! WRITE(IUNIT,'(1x,I6,2x,I6,2x,I6,2x,I6)')I,J,LLOW(I,J),LUPP(I,J)
WRITE(IUNIT,'(1x,I6,2x,I6,2(2x,I6,2x,F12.3))') I, J, &
@@ -3778,7 +3891,7 @@ SUBROUTINE MISCLN
IF (iget2 > 0) then
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = HELI(I,J,1)
! GRID1(I,J) = HELI(I,J,2)
ENDDO
@@ -3787,11 +3900,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(iget1)
fld_info(cfld)%lvl=LVLSXML(1,iget1)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3804,14 +3918,14 @@ SUBROUTINE MISCLN
!EL field allocation
- allocate(ESHR(IM,jsta_2l:jend_2u),UVECT(IM,jsta_2l:jend_2u),&
- VVECT(IM,jsta_2l:jend_2u),HTSFC(IM,jsta_2l:jend_2u))
- allocate(EFFUST(IM,jsta_2l:jend_2u),EFFVST(IM,jsta_2l:jend_2u),&
- ESRH(IM,jsta_2l:jend_2u))
+ allocate(ESHR(ista_2l:iend_2u,jsta_2l:jend_2u),UVECT(ista_2l:iend_2u,jsta_2l:jend_2u),&
+ VVECT(ista_2l:iend_2u,jsta_2l:jend_2u),HTSFC(ista_2l:iend_2u,jsta_2l:jend_2u))
+ allocate(EFFUST(ista_2l:iend_2u,jsta_2l:jend_2u),EFFVST(ista_2l:iend_2u,jsta_2l:jend_2u),&
+ ESRH(ista_2l:iend_2u,jsta_2l:jend_2u))
!
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
MAXTHE(I,J)=-H99999
THE(I,J)=-H99999
MAXTHEPOS(I,J)=0
@@ -3821,7 +3935,7 @@ SUBROUTINE MISCLN
DO L=LM,1,-1
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EGRID1(I,J) = -H99999
P1D(I,J)=PMID(I,J,L)
T1D(I,J)=T(I,J,L)
@@ -3830,7 +3944,7 @@ SUBROUTINE MISCLN
ENDDO
CALL CALTHTE(P1D,T1D,Q1D,EGRID1)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
THE(I,J)=EGRID1(I,J)
IF(THE(I,J)>=MAXTHE(I,J))THEN
MAXTHE(I,J)=THE(I,J)
@@ -3851,8 +3965,8 @@ SUBROUTINE MISCLN
IVE(J) = MOD(J,2)
IVW(J) = IVE(J)-1
enddo
- ISTART = 2
- ISTOP = IM-1
+ ISTART = ISTA_M
+ ISTOP = IEND_M
JSTART = JSTA_M
JSTOP = JEND_M
ELSE IF(gridtype == 'B')THEN
@@ -3862,8 +3976,8 @@ SUBROUTINE MISCLN
IVE(J)=1
IVW(J)=0
enddo
- ISTART = 2
- ISTOP = IM-1
+ ISTART = ISTA_M
+ ISTOP = IEND_M
JSTART = JSTA_M
JSTOP = JEND_M
ELSE
@@ -3873,13 +3987,13 @@ SUBROUTINE MISCLN
IVE(J) = 0
IVW(J) = 0
enddo
- ISTART = 1
- ISTOP = IM
+ ISTART = ISTA
+ ISTOP = IEND
JSTART = JSTA
JSTOP = JEND
END IF
- IF(gridtype /= 'A') CALL EXCH(FIS(1:IM,JSTA:JEND))
+ IF(gridtype /= 'A') CALL EXCH(FIS(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U))
DO J=JSTART,JSTOP
DO I=ISTART,ISTOP
IE = I+IVE(J)
@@ -3898,7 +4012,7 @@ SUBROUTINE MISCLN
IF (IGET(979)>0) THEN
GRID1=spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(ZINT(I,J,LLOW(I,J))0) THEN
GRID1=spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(ZINT(I,J,LUPP(I,J))0) THEN
GRID1=spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(LLOW(I,J)0) THEN
GRID1=spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(LLOW(I,J)0) THEN
GRID1=spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(UVECT(I,J)0) THEN
GRID1=spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(LLOW(I,J)0) THEN
GRID1=spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(LLOW(I,J)0) THEN
GRID1=spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(LLOW(I,J)0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (MLLCL(I,J)>D2000) THEN
MLLCLtmp=D00
ELSEIF (MLLCL(I,J)0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
LLMH = NINT(LMH(I,J))
P1D(I,J) = PMID(I,J,LLMH)
T1D(I,J) = T(I,J,LLMH)
@@ -4164,7 +4287,7 @@ SUBROUTINE MISCLN
ENDDO
CALL CALLCL(P1D,T1D,Q1D,EGRID1,EGRID2)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
SLCL(I,J)=EGRID2(I,J)
ENDDO
ENDDO
@@ -4177,7 +4300,7 @@ SUBROUTINE MISCLN
EGRID3,dummy,dummy)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (SLCL(I,J)>D2000) THEN
SLCLtmp=D00
ELSEIF (SLCL(I,J)<=D1000) THEN
@@ -4215,11 +4338,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(990))
fld_info(cfld)%lvl=LVLSXML(1,IGET(990))
-! $omp parallel do private(i,j,jj)
+! $omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4228,7 +4352,7 @@ SUBROUTINE MISCLN
!Effective Layer Supercell Parameter
IF (IGET(991)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (ESHR(I,J)<10.) THEN
ESHRtmp=D00
ELSEIF (ESHR(I,J)>20.0) THEN
@@ -4257,11 +4381,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(991))
fld_info(cfld)%lvl=LVLSXML(1,IGET(991))
-! $omp parallel do private(i,j,jj)
+! $omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4272,7 +4397,7 @@ SUBROUTINE MISCLN
IF (IGET(992)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EGRID1(I,J) = -H99999
EGRID2(I,J) = -H99999
EGRID3(I,J) = -H99999
@@ -4300,7 +4425,7 @@ SUBROUTINE MISCLN
GRID1=spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) GRID1(I,J) = EGRID3(I,J)
ENDDO
ENDDO
@@ -4309,11 +4434,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(992))
fld_info(cfld)%lvl=LVLSXML(1,IGET(992))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4324,7 +4450,7 @@ SUBROUTINE MISCLN
!$omp parallel do private(i,j)
! EGRID3 is Virtual LFC
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = Q1D(I,J)
ENDDO
ENDDO
@@ -4332,11 +4458,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(763))
fld_info(cfld)%lvl=LVLSXML(1,IGET(763))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4346,7 +4473,7 @@ SUBROUTINE MISCLN
IF (IGET(993)>0) THEN
GRID1=spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
LAPSE=-((T700(I,J)-T500(I,J))/((Z700(I,J)-Z500(I,J))))
SHIP=(MUCAPE(I,J)*D1000*MUQ1D(I,J)*LAPSE*(T500(I,J)-K2C)*FSHR(I,J))/HCONST
IF (MUCAPE(I,J)<1300.)THEN
@@ -4365,11 +4492,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(993))
fld_info(cfld)%lvl=LVLSXML(1,IGET(993))
-! $omp parallel do private(i,j,jj)
+! $omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4384,7 +4512,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval ) GRID1(I,J) = CANGLE(I,J)
! IF(EGRID1(I,J)<100. .OR. EGRID2(I,J)>-250.) THEN
! GRID1(I,J) = 0.
@@ -4395,11 +4523,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(957))
fld_info(cfld)%lvl=LVLSXML(1,IGET(957))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4411,7 +4540,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval ) GRID1(I,J) = EGRID7(I,J)
ENDDO
ENDDO
@@ -4420,11 +4549,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(955))
fld_info(cfld)%lvl=LVLSXML(1,IGET(955))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4436,7 +4566,7 @@ SUBROUTINE MISCLN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval ) GRID1(I,J) = EGRID8(I,J)
ENDDO
ENDDO
@@ -4445,11 +4575,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(956))
fld_info(cfld)%lvl=LVLSXML(1,IGET(956))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4477,7 +4608,7 @@ SUBROUTINE MISCLN
GRID1 = spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T1D(I,J) < spval) GRID1(I,J) = -EGRID6(I,J)
ENDDO
ENDDO
@@ -4486,11 +4617,12 @@ SUBROUTINE MISCLN
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(954))
fld_info(cfld)%lvl=LVLSXML(1,IGET(954))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4530,15 +4662,16 @@ SUBROUTINE MISCLN
!
! RELATIVE HUMIDITY WITH RESPECT TO PRECIPITABLE WATER
IF (IGET(749)>0) THEN
- CALL CALRH_PW(GRID1(1,jsta))
+ CALL CALRH_PW(GRID1(ista:iend,jsta:jend))
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(749))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
diff --git a/sorc/ncep_post.fd/MIXLEN.f b/sorc/ncep_post.fd/MIXLEN.f
index 33c02dd7e..767bcad0e 100644
--- a/sorc/ncep_post.fd/MIXLEN.f
+++ b/sorc/ncep_post.fd/MIXLEN.f
@@ -10,6 +10,7 @@ SUBROUTINE MIXLEN(EL0,EL)
! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT
! 02-06-19 MIKE BALDWIN - WRF VERSION
! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend)
+! 21-09-30 J MENG - 2D DECOMPOSITION
!
!
! INPUT:
@@ -42,7 +43,8 @@ SUBROUTINE MIXLEN(EL0,EL)
use masks, only: lmh, htm
use params_mod, only: EPSQ2, CAPA
use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, im, jm, jsta_2l, jend_2u,&
- lm, lm1, spval
+ lm, lm1, spval,&
+ ista, iend, ista_m, iend_m, ista_2l, iend_2u
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
@@ -54,9 +56,9 @@ SUBROUTINE MIXLEN(EL0,EL)
!
! ------------------------------------------------------------------
!
- real,intent(in) :: el0(im,jsta_2l:jend_2u)
- real,intent(out) :: EL(IM,jsta_2l:jend_2u,LM)
- real HGT(IM,JSTA:JEND),APE(IM,JSTA_M:JEND_M,2)
+ real,intent(in) :: el0(ista_2l:iend_2u,jsta_2l:jend_2u)
+ real,intent(out) :: EL(ista_2l:iend_2u,jsta_2l:jend_2u,LM)
+ real HGT(ISTA:IEND,JSTA:JEND),APE(ISTA_M:IEND_M,JSTA_M:JEND_M,2)
!
integer I,J,L
real ZL,VKRMZ,ENSQ,Q2KL,ELST,ZIAG,ELVGD
@@ -66,13 +68,13 @@ SUBROUTINE MIXLEN(EL0,EL)
!$omp parallel do
DO L=1,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EL(I,J,L)=0.
ENDDO
ENDDO
ENDDO
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
HGT(I,J)=ZINT(I,J,NINT(LMH(I,J))+1)
ENDDO
ENDDO
@@ -83,7 +85,7 @@ SUBROUTINE MIXLEN(EL0,EL)
!$omp parallel do private(i,j,l,vkrmz,zl)
DO L=1,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(HGT(I,J)=(num_procs-numx))then
+ jend_m=jm-1
+ jend_m2=jm-2
+ end if
+
+ if(mod(me+1,numx)==0)then
+ iend_m=im-1
+ iend_m2=im-2
+ end if
+
+ 102 format(6i10,a20)
+
+!
if ( me == 0 ) then
- idn = MPI_PROC_NULL
+ idn = MPI_PROC_NULL
end if
if ( me == num_procs - 1 ) then
- iup = MPI_PROC_NULL
+ iup = MPI_PROC_NULL
end if
!
-! print *, ' ME, NUM_PROCS = ',me,num_procs
-! print *, ' ME, JSTA, JSTA_M, JSTA_M2 = ',me,jsta,jsta_m,jsta_m2
-! print *, ' ME, JEND, JEND_M, JEND_M2 = ',me,jend,jend_m,jend_m2
-! print *, ' ME, IUP, IDN = ',me,iup,idn
-!
-! counts, disps for gatherv and scatterv
-!
- do i = 0, num_procs - 1
- call para_range(1,jm,num_procs,i,jsx,jex)
- icnt(i) = (jex-jsx+1)*im
- idsp(i) = (jsx-1)*im
- if ( me == 0 ) then
- print *, ' i, icnt(i),idsp(i) = ',i,icnt(i), &
- idsp(i)
- end if
+! GWV. Array of i/j coordinates for bookkeeping tests. Not used in
+! calculations but to check if scatter,gather, and exchanges are doing as
+! expected. Both real and integer arrays are sent. Integer will be needed
+! for very large domains because real mantissas overflow and both coordinates'
+! information can't be packed into a real mantisa. Real is easier to use
+! because the datatype is the same as for actual data
+
+ allocate(icoords(im,jm))
+ allocate(rcoords(im,jm))
+ allocate(ibuff(im*jm))
+ allocate(rbuff(im*jm))
+ do j=1,jm
+ do i=1,im
+ icoords(i,j)=10000*I+j ! both I and J information is in each element
+ rcoords(i,j)=4000*i+j ! both I and J information is in each element but it overflows for large I I to 3600 is safe
+ end do
end do
+
+! end COORDS test
+
+! counts, disps for gatherv and scatterv
+
+ isum=1
+ allocate(isxa(0:num_procs-1) )
+ allocate(jsxa(0:num_procs-1) )
+ allocate(iexa(0:num_procs-1) )
+ allocate(jexa(0:num_procs-1) )
+ do i = 0, num_procs - 1
+ call para_range2(im,jm,numx,num_procs/numx,i,isx,iex,jsx,jex)
+ icnt(i) = ((jex-jsx)+1)*((iex-isx)+1)
+ isxa(i)=isx
+ iexa(i)=iex
+ jsxa(i)=jsx
+ jexa(i)=jex
+
+ idsp(i)=isumm
+ isumm=isumm+icnt(i)
+ if(jsx .eq. 1 .or. jex .eq. jm) then
+ icnt2(i) = (iex-isx+1)
+ else
+ icnt2(i)=0
+ endif
+ idsp2(i)=isumm2
+ if(jsx .eq. 1 .or. jex .eq. jm) isumm2=isumm2+(iex-isx+1)
+
+! GWV Create send buffer for scatter. This is now needed because we are no
+! longer sending contiguous slices of the im,jm full state arrays to the
+! processors with scatter. Instead we are sending a slice of I and a slice of J
+! and so have to reshape the send buffer below to make it contiguous groups of
+! isx:iex,jsx:jex arrays
+
+ do jj=jsx,jex
+ do ii=isx,iex
+ ibuff(isum)=icoords(ii,jj)
+ rbuff(isum)=rcoords(ii,jj)
+ isum=isum+1
+ end do
+ end do
+
+ end do ! enddo of num_procs
!
! extraction limits -- set to two rows
!
jsta_2l = max(jsta - 2, 1 )
jend_2u = min(jend + 2, jm )
+ if(modelname=='GFS') then
+ ista_2l=max(ista-2,0)
+ iend_2u=min(iend+2,im+1)
+ else
+ ista_2l=max(ista-2,1)
+ iend_2u=min(iend+2,im)
+ endif
+
! special for c-grid v
jvend_2u = min(jend + 2, jm+1 )
-! special for c-grid v
-! print *, ' me, jvend_2u = ',me,jvend_2u
!
+! NEW neighbors
+
+ ileft = me - 1
+ iright = me + 1
+ iup=MPI_PROC_NULL
+ idn=MPI_PROC_NULL
+
+ if(mod(me,numx) .eq. 0) print *,' LEFT POINT',me
+ if(mod(me+1,numx) .eq. 0) print *,' RIGHT POINT',me
+ if(mod(me,numx) .eq. 0) ileft=MPI_PROC_NULL
+ if(mod(me,numx) .eq. 0) ileftb=me+numx-1
+ if(mod(me+1,numx) .eq. 0 .or. me .eq. num_procs-1) iright=MPI_PROC_NULL
+ if(mod(me+1,numx) .eq. 0 .or. me .eq. num_procs-1) irightb=me-numx+1
+ if(me .ge. numx) idn=me-numx
+ if(me+1 .le. num_procs-numx) iup=me+numx
+
+ print 102,me,ileft,iright,iup,idn,num_procs,'GWVX BOUNDS'
+
! allocate arrays
+
+ ibsize = ( (iend-ista) +1) * ( (jend-jsta)+1)
+ allocate(ibcoords(ista_2l:iend_2u,jsta_2l:jend_2u))
+ allocate(rbcoords(ista_2l:iend_2u,jsta_2l:jend_2u))
+ allocate(ibufs(ibsize))
+ allocate(rbufs(ibsize))
+ call mpi_scatterv(ibuff,icnt,idsp,mpi_integer &
+ ,ibufs,icnt(me),mpi_integer ,0,MPI_COMM_WORLD,j)
+ call mpi_scatterv(rbuff,icnt,idsp,mpi_real &
+ ,rbufs,icnt(me),mpi_real ,0,MPI_COMM_WORLD,j)
+
!
-!
-! FROM VRBLS3D
+!GWV reshape the receive subdomain
+
+ isum=1
+ do j=jsta,jend
+ do i=ista,iend
+ ibcoords(i,j)=ibufs(isum)
+ rbcoords(i,j)=rbufs(isum)
+ isum=isum+1
+ end do
+ end do
+
+!GWV end reshape
+ do j=jsta,jend
+ do i=ista,iend
+ ii=ibcoords(i,j)/10000
+ jj=ibcoords( i,j)-(ii*10000)
+ if(ii .ne. i .or. jj .ne. j) then
+ print *,i,j,ii,jj,ibcoords(i,j),' GWVX FAIL '
+ else
+ continue
+ endif
+ end do
+ end do
+
+ allocate(ipoles(im,2),ipole(ista:iend))
+ allocate(rpoles(im,2),rpole(ista:iend))
+ ipole=9900000
+ ipoles=-999999999
+
+ do i=ista,iend
+ if(me .lt. num_procs/2. .and. jsta_2l .le. 1 .and. icnt2(me) .gt. 0) ipole(i)=ibcoords(i,1)
+ if(me .lt. num_procs/2. .and. jsta_2l .le. 1 .and. icnt2(me) .gt. 0) rpole(i)=rbcoords(i,1)
+ if(me .gt. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt. 0) ipole(i)=ibcoords(i,jm)
+ if(me .gt. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt. 0) rpole(i)=rbcoords(i,jm)
+
+! check code to be removed upon debugging
+ if(me .lt. num_procs/2. .and. jsx .eq. 1) then
+ continue
+ endif
+ if(me .gt. num_procs/2. .and. jend_2u .ge. jm) then
+ continue
+ endif
+ end do ! end check code
+
+! test pole gather
+ print 105,' GWVX GATHER DISP ',icnt2(me),idsp2(me),me
+ 105 format(a30,3i12)
+
+ call mpi_gatherv(ipole(ista),icnt2(me),MPI_INTEGER, ipoles,icnt2,idsp2,MPI_INTEGER,0,MPI_COMM_WORLD, ierr )
+ call mpi_gatherv(rpole(ista),icnt2(me),MPI_REAL , rpoles,icnt2,idsp2,MPI_REAL ,0,MPI_COMM_WORLD, ierr )
+
+ if(me .eq. 0) then
+ do j=1,2
+ do i=1,im
+ ii=rpoles(i,j)/4000
+ jj=rpoles(i,j) -ii*4000
+ if(ii .ne. i .or. jj .ne. 1 .and. jj .ne. jm ) then
+ write(0,169)' IPOLES BAD POINT',rpoles(i,j),ii,i,jj,' jm= ',jm
+ else
+ continue
+! write(0,169)' IPOLES GOOD POINT',rpoles(i,j),ii,i,jj,' jm= ',jm
+ endif
+ end do
+ end do
+ endif
+
+ 107 format(a20,10i10)
+ 169 format(a25,f20.1,3i10,a10,4i10)
!
print *, ' me, jsta_2l, jend_2u = ',me,jsta_2l, jend_2u, &
'jvend_2u=',jvend_2u,'im=',im,'jm=',jm,'lm=',lm, &
'lp1=',lp1
+ write(0,'(A,5I10)') 'MPI_FIRST me,jsta,jend,ista,iend,=',me,jsta,jend,ista,iend
+
+ end
+
+! subroutine sub(a)
+! return
+! end
+
+
+
+ subroutine fullpole(a,rpoles)
+
+ use ctlblk_mod, only: num_procs, jend, iup, jsta, idn, mpi_comm_comp, im,MODELNAME,numx,&
+ icoords,ibcoords,rbcoords,bufs,ibufs,me, &
+ jsta_2l,jend_2u,ileft,iright,ista_2l,iend_2u,ista,iend,jm,icnt2,idsp2
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ implicit none
+!
+ include 'mpif.h'
+!
+ real,intent(inout) :: a ( ista_2l:iend_2u,jsta_2l:jend_2u ),rpoles(im,2)
+ real, allocatable :: rpole(:)
+
+ integer status(MPI_STATUS_SIZE)
+ integer ierr
+ integer size,ubound,lbound
+ integer i,ii,jj, ibl,ibu,jbl,jbu,icc,jcc
+ integer ifirst
+ data ifirst/0/
+ integer iwest,ieast
+ data iwest,ieast/0,0/
+ allocate(rpole(ista:iend))
+
+ do i=ista,iend
+ if(me .lt. num_procs/2. .and. jsta_2l .le. 1 .and. icnt2(me) .gt. 0) rpole(i)=a(i,1)
+ if(me .ge. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt. 0) rpole(i)=a(i,jm)
+ end do
+
+ call mpi_allgatherv(rpole(ista),icnt2(me),MPI_REAL,rpoles,icnt2,idsp2,MPI_REAL, MPI_COMM_COMP,ierr)
+
+ call mpi_barrier(mpi_comm_comp,ierr)
+ ifirst=1
end
+
diff --git a/sorc/ncep_post.fd/MSFPS.f b/sorc/ncep_post.fd/MSFPS.f
index 06b2bc63d..14aa915d4 100644
--- a/sorc/ncep_post.fd/MSFPS.f
+++ b/sorc/ncep_post.fd/MSFPS.f
@@ -1,25 +1,18 @@
!> @file
-! . . .
-!> SUBPROGRAM: MSFPS Computes the map scale factor for a Polar
-!! Stereographic grid at a give latitude.
-!!
-!! ABSTRACT:
-!! Computes the map scale factor for a Polar Stereographic
-!! grid at a give latitude.
-!!
-!! PROGRAM HISTORY LOG:
-!! 06-11-01 SWIPED FROM WRF SI PACKAGE BY ROZUMALSKI
-!!
-!! INPUT ARGUMENT LIST:
-!! LAT - LATITUDE AT WHICH MAP FACTOR IS VALID
-!! TRUELAT1 - TRUELAT 1
-!!
-!! OUTPUT ARGUMENT LIST:
-!! MSF - MAP SCALE FACTOR
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!!
+!> @brief msfps() computes the map scale factor for a polar stereographic grid at a give latitude.
+!>
+!> This subroutine computes the map scale factor for a polar stereographic grid at a give latitude.
+!>
+!> @param[in] LAT Latitude at which map factor is valid.
+!> @param[in] TRUELAT1 TRUELAT 1.
+!> @param[out] MSF Map scale factor.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2006-11-01 | Rozumalski | Swiped from WRF si package
+!>
+!> @author Rozumalski @date 2006-11-01
SUBROUTINE MSFPS(LAT,TRUELAT1,MSF)
diff --git a/sorc/ncep_post.fd/NGMFLD.f b/sorc/ncep_post.fd/NGMFLD.f
index 7bd962e14..2d7052e35 100644
--- a/sorc/ncep_post.fd/NGMFLD.f
+++ b/sorc/ncep_post.fd/NGMFLD.f
@@ -1,81 +1,48 @@
!> @file
-! . . .
-!> SUBPROGRAM: NGMFLD COMPUTES LAYER MEAN NGM FIELDS
-!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22
-!!
-!! ABSTRACT:
-!! THIS ROUTINE COMPUTES A HANDFUL OF NGM LAYER MEAN
-!! FIELDS. THIS IS DONE TO PROVIDE A FULLY COMPLETE
-!! ETA NGM LOOK-ALIKE OUTPUT FILE. THE SIGMA (LAYER)
-!! FIELDS COMPUTED BY THIS ROUTINE ARE TABULATED BELOW.
-!!
-!! SIGMA (LAYER) FIELD(S)
-!! --------------- --------------
-!! 0.47191-1.00000 RH
-!! 0.47171-0.96470 RH
-!! 0.18019-0.47191 RH
-!! 0.84368-0.98230 RH
-!! 0.85000-1.00000 MCONV
-!! WHERE
-!! RH = RELATIVE HUMIDITY
-!! MCONV = MOISTURE CONVERGENCE
-!!
-!! LAYER MEANS ARE A SUMMATION OVER ETA LAYERS MAPPING INTO
-!! THE PRESSURE RANGE CORRESPONDING TO THE SIGMA RANGE ABOVE.
-!! THE CALCULATION OF THESE BOUNDING PRESSURES IS DONE AT
-!! EACH HORIZONTAL GRID POINT BASED ON THE SURFACE PRESSURE.
-!! EACH TERM IN THE SUMMATION IS WEIGHTED BY THE THICKNESS OF
-!! THE ETA LAYER. THE FINAL LAYER MEAN IS THIS SUM NORMALIZED
-!! BY THE TOTAL DEPTH OF THE LAYER.
-
-!!
-!!
-!! PROGRAM HISTORY LOG:
-!! 92-12-22 RUSS TREADON
-!! 93-07-27 RUSS TREADON - MODIFIED SUMMATION LIMITS FROM
-!! 0.66*PSFC TO 0.75*PSFC AND 0.33*PSFC
-!! TO 0.50*PSFC, WHERE PSFC IS THE
-!! SURFACES PRESSURE. THE REASON FOR
-!! THIS CHANGE WAS RECOGNITION THAT IN
-!! THE LFM 0.33 AND 0.66 WERE MEASURED
-!! FROM THE SURFACE TO THE TROPOPAUSE,
-!! NOT THE TOP OF THE MODEL.
-!! 93-09-13 RUSS TREADON - RH CALCULATIONS WERE MADE INTERNAL
-!! TO THE ROUTINE.
-!! 98-06-16 T BLACK - CONVERSION FROM 1-D TO 2-D
-!! 98-08-18 MIKE BALDWIN - COMPUTE RH OVER ICE
-!! 98-12-22 MIKE BALDWIN - BACK OUT RH OVER ICE
-!! 00-01-04 JIM TUCCILLO - MPI VERSION
-!! 02-04-24 MIKE BALDWIN - WRF VERSION
-!!
-!!
-!! USAGE: CALL NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510)
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! RH4710 - SIGMA LAYER 0.47-1.00 MEAN RELATIVE HUMIDITY.
-!! RH4796 - SIGMA LAYER 0.47-0.96 MEAN RELATIVE HUMIDITY.
-!! RH1847 - SIGMA LAYER 0.18-0.47 MEAN RELATIVE HUMIDITY.
-!! RH8498 - SIGMA LAYER 0.84-0.98 MEAN RELATIVE HUMIDITY.
-!! QM8510 - SIGMA LAYER 0.85-1.00 MEAN MOISTURE CONVERGENCE.
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! LIBRARY:
-!! COMMON -
-!! MASKS
-!! OPTIONS
-!! LOOPS
-!! MAPOT
-!! DYNAMD
-!! INDX
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
+!> @brief ngmfld() computes layer mean NGM fields
+!>
+!> This routine computes a handful of NGM layer mean
+!> fields. This is done to provide a fully complete
+!> ETA NGM look-alike output file.
+!> ### The sigma (layer) fields computed bu this routine are tabulated below.
+!> Sigma (layer) | Field(s) |
+!> --------------|----------|
+!> 0.47191 - 1.00000 | RH |
+!> 0.47171 - 0.96470 | RH |
+!> 0.18019 - 0.47191 | RH |
+!> 0.84368 - 0.98230 | RH |
+!> 0.85000 - 1.00000 | MCONV |
+!> where RH = Relative humidity and MCONV = Moisture convergence
+!>
+!> Layer means are a summation over ETA layers mapping into
+!> The pressure range corresponding to the sigma range above.
+!> The calculation of these bounding pressures is done at
+!> each horizontal grid point based on the surface pressure.
+!> Each term in the summation is weighted by the thickness of
+!> the ETA layer. The final layer mean is this sum normalized
+!> by the total depth of the layer.
+!>
+!> @param[out] RH4710 Sigma layer 0.47-1.00 mean relative humidity.
+!> @param[out] RH4796 Sigma layer 0.47-0.96 mean relative humidity.
+!> @param[out] RH1847 Sigma layer 0.18-0.47 mean relative humidity.
+!> @param[out] RH8498 Sigma layer 0.84-0.98 mean relative humidity.
+!> @param[out] QM8510 Sigma layer 0.85-1.00 mean moisture convergence.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1992-12-22 | Russ Treadon | Initial
+!> 1993-07-27 | Russ Treadon | Modified summation limits from 0.66*PSFC to 0.75*PSFC and 0.33*PSFC to 0.50*PSFC, where PSFC is the surfaces pressure. The reason for this change was recognition that in the LFM 0.33 and 0.66 were measured from the surface to the tropopause not the top of the model.
+!> 1993-09-13 | Russ Treadon | RH calculations were made internal to the routine.
+!> 1996-03-04 | Mike Baldwin | Change PW CALC to include CLD WTR
+!> 1998-06-16 | T Black | Conversion from 1-D to 2-D
+!> 1998-08-17 | Mike Baldwin | Compute RH over ice
+!> 1998-12-22 | Mike Baldwin | Back out RH over ice
+!> 2000-01-04 | Jim Tuccillo | MPI Version
+!> 2002-04-24 | Mike Baldwin | WRF Version
+!> 2021-09-30 | JESSE MENG | 2D DECOMPOSITION
+!>
+!> @author Russ Treadon W/NP2 @date 1992-12-22
SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510)
!
@@ -85,7 +52,8 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510)
use masks, only: lmh
use params_mod, only: d00, d50, h1m12, pq0, a2, a3, a4, h1, d01, small
use ctlblk_mod, only: jsta, jend, lm, jsta_2l, jend_2u, jsta_m2, jend_m2,&
- spval, im
+ spval, im, &
+ ista, iend, ista_2l, iend_2u, ista_m2, iend_m2, ista_m, iend_m
!
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
@@ -96,10 +64,10 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510)
!
! DECLARE VARIABLES.
LOGICAL GOT8510,GOT4710,GOT4796,GOT1847,GOT8498
- REAL,dimension(IM,jsta_2l:jend_2u),intent(out) :: QM8510,RH4710,RH8498, &
+ REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(out) :: QM8510,RH4710,RH8498, &
RH4796,RH1847
- REAL,dimension(im,jsta_2l:jend_2u) :: Z8510,Z4710,Z8498,Z4796,Z1847
- real,dimension(im,jsta_2l:jend_2u) :: Q1D, U1D, V1D, QCNVG
+ REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: Z8510,Z4710,Z8498,Z4796,Z1847
+ real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: Q1D, U1D, V1D, QCNVG
!
integer I,J,L
real P100,P85,P98,P96,P84,P47,P18,ALPM,DE,PM,TM,QM, &
@@ -110,7 +78,7 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510)
! INITIALIZE ARRAYS.
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
QM8510(I,J) = D00
RH4710(I,J) = D00
RH8498(I,J) = D00
@@ -137,7 +105,7 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510)
! COMPUTE MOISTURE CONVERGENCE
!$omp parallel do private(i,j)
DO J=JSTA_2L,JEND_2U
- DO I=1,IM
+ DO I=ISTA_2L,IEND_2U
Q1D(I,J) = Q(I,J,L)
U1D(I,J) = UH(I,J,L)
V1D(I,J) = VH(I,J,L)
@@ -146,7 +114,7 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510)
CALL CALMCVG(Q1D,U1D,V1D,QCNVG)
! COMPUTE MOISTURE CONVERGENCE
DO J=JSTA_M2,JEND_M2
- DO I=2,IM-1
+ DO I=ISTA_M,IEND_M
!
! SET TARGET PRESSURES.
@@ -220,7 +188,7 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510)
ENDDO
!
DO J=JSTA_M2,JEND_M2
- DO I=2,IM-1
+ DO I=ISTA_M,IEND_M
! NORMALIZE TO GET LAYER MEAN VALUES.
IF (Z8510(I,J)>0) THEN
QM8510(I,J) = QM8510(I,J)/Z8510(I,J)
diff --git a/sorc/ncep_post.fd/NGMSLP.f b/sorc/ncep_post.fd/NGMSLP.f
index 56fdda56c..40f8bdb1c 100644
--- a/sorc/ncep_post.fd/NGMSLP.f
+++ b/sorc/ncep_post.fd/NGMSLP.f
@@ -65,6 +65,7 @@
!! CONSISTENT WITH MESINGER SLP
!! 02-06-13 MIKE BALDWIN - WRF VERSION
!! 06-12-18 H CHUANG - BUG FIX TO CORRECT TAU AT SFC
+!! 21-09-30 J MENG - 2D DECOMPOSITION
!!
!! USAGE: CALL NGMSLP
!! INPUT ARGUMENT LIST:
@@ -93,7 +94,7 @@ SUBROUTINE NGMSLP
use vrbls2d, only: slp, fis, z1000
use masks, only: lmh
use params_mod, only: rd, gi, g, h1, d608, gamma, d50, p1000
- use ctlblk_mod, only: jsta, jend, im, jm, spval
+ use ctlblk_mod, only: jsta, jend, im, jm, spval, ista, iend
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
!
@@ -117,7 +118,7 @@ SUBROUTINE NGMSLP
!!$omp& tau,tauavg,tausfc,tausl,tavg,tvrbar,tvrsfc,tvrsl,
!!$omp& tvrt,tvrtal,zbar,zl,zsfc)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
LLMH = NINT(LMH(I,J))
if( PINT(I,J,LLMH+1) @file
-!
-!> SUBPROGRAM: OTLFT COMPUTES LIFTED INDEX
-!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-03-10
-!!
-!! ABSTRACT:
-!! THIS ROUTINE COMPUTES LIFTS A PARCEL SPECIFIED BY THE
-!! PASSED PRESSURE, TEMPERATURE, AND SPECIFIC HUMIDITY TO
-!! 500MB AND THEN COMPUTES A LIFTED INDEX. THIS LIFTED
-!! LIFTED INDEX IS THE DIFFERENCE BETWEEN THE LIFTED
-!! PARCEL'S TEMPERATURE AT 500MB AND THE AMBIENT 500MB
-!! TEMPERATURE.
-!!
-!! PROGRAM HISTORY LOG:
-!! 93-03-10 RUSS TREADON - MODIFIED OTLIFT2 TO LIFT PARCELS
-!! SPECIFIED BY PASSED P, T, AND Q.
-!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D
-!! 00-01-04 JIM TUCCILLO - MPI VERSION
-!! 02-06-17 MIKE BALDWIN - WRF VERSION
-!! 11-04-12 GEOFF MANIKIN - USE VIRTUAL TEMPERATURE
-!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE
-!!
-!! USAGE: CALL OTLFT(PBND,TBND,QBND,SLINDX)
-!! INPUT ARGUMENT LIST:
-!! PBND - PARCEL PRESSURE.
-!! TBND - PARCEL TEMPERATURE.
-!! QBND - PARCEL SPECIFIC HUMIDITY.
-!!
-!! OUTPUT ARGUMENT LIST:
-!! SLINDX - LIFTED INDEX.
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! NONE
-!! LIBRARY:
-!! COMMON - CTLBLK
-!! LOOPS
-!! MASKS
-!! PHYS
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
+!> @brief otlft() computes lifted index.
+!>
+!> This routine computes lifts a parcel specified by the
+!> passed pressure, temperature, and specific humidity to
+!> 500mb and then computes a lifted index. This lifted
+!> lifted index is the difference between the lifted
+!> parcel's temperature at 500mb and the ambient 500mb
+!> temperature.
+!>
+!> @param[in] PBND Parcel pressure.
+!> @param[in] TBND Parcel temperature.
+!> @param[in] QBND Parcel specific humidity.
+!> @param[out] SLINDX Lifted index.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1993-03-10 | Russ Treadon | Initial. Modified OTLIFT2 to lift parcels specified by passed P, T, and Q.
+!> 1998-06-15 | T Black | Conversion from 1-D to 2-D
+!> 2000-01-04 | Jim Tuccillo | MPI Version
+!> 2002-06-17 | Mike Baldwin | WRF Version
+!> 2011-04-12 | Geoff Manikin | Use virtual temperature
+!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS Module
+!> 2021-09-30 | JESSE MENG | 2D DECOMPOSITION
+!>
+!> @author Russ Treadon W/NP2 @date 1993-03-10
SUBROUTINE OTLFT(PBND,TBND,QBND,SLINDX)
!
@@ -52,7 +32,7 @@ SUBROUTINE OTLFT(PBND,TBND,QBND,SLINDX)
use vrbls2d, only: T500
use lookup_mod, only: THL, RDTH, JTB, QS0, SQS, RDQ, ITB, PTBL, &
PL, RDP, THE0, STHE, RDTHE, TTBL
- use ctlblk_mod, only: JSTA, JEND, IM, spval
+ use ctlblk_mod, only: JSTA, JEND, IM, spval, ISTA, IEND
use params_mod, only: D00, H10E5, CAPA, ELOCP, EPS, ONEPS
use upp_physics, only: FPVSNEW
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -63,8 +43,8 @@ SUBROUTINE OTLFT(PBND,TBND,QBND,SLINDX)
!
! DECLARE VARIABLES.
- real,dimension(IM,jsta:jend),intent(in) :: PBND,TBND,QBND
- real,dimension(IM,jsta:jend),intent(out) :: SLINDX
+ real,dimension(ista:iend,jsta:jend),intent(in) :: PBND,TBND,QBND
+ real,dimension(ista:iend,jsta:jend),intent(out) :: SLINDX
REAL :: TVP, ESATP, QSATP
REAL :: BQS00, SQS00, BQS10, SQS10, P00, P10, P01, P11, BQ, SQ, TQ
REAL :: BTHE00, STHE00, BTHE10, STHE10, BTH, STH, TTH
@@ -81,7 +61,7 @@ SUBROUTINE OTLFT(PBND,TBND,QBND,SLINDX)
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
SLINDX(I,J) = D00
ENDDO
ENDDO
@@ -89,7 +69,7 @@ SUBROUTINE OTLFT(PBND,TBND,QBND,SLINDX)
!--------------FIND EXNER IN BOUNDARY LAYER-----------------------------
!
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
TBT = TBND(I,J)
QBT = QBND(I,J)
!
diff --git a/sorc/ncep_post.fd/OTLIFT.f b/sorc/ncep_post.fd/OTLIFT.f
index f1abe6575..2270113da 100644
--- a/sorc/ncep_post.fd/OTLIFT.f
+++ b/sorc/ncep_post.fd/OTLIFT.f
@@ -1,44 +1,28 @@
!> @file
-!
-!> SUBPROGRAM: OTLIFT COMPUTES SFC TO 500MB LIFTED INDEX
-!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-03-10
-!!
-!! ABSTRACT:
-!! THIS ROUTINE COMPUTES A SURFACE TO 500MB LIFTED INDEX.
-!! THE LIFTED PARCEL IS FROM THE FIRST ATMOSPHERIC ETA
-!! LAYER (IE, THE ETA LAYER CLOSEST TO THE MODEL GROUND).
-!! THE LIFTED INDEX IS THE DIFFERENCE BETWEEN THIS PARCEL'S
-!! TEMPERATURE AT 500MB AND THE AMBIENT 500MB TEMPERATURE.
-!!
-!! PROGRAM HISTORY LOG:
-!! ??-??-?? ??? - SUBROUTINE OTLIFT IN ETA MODEL.
-!! 93-03-10 RUSS TREADON - ADAPTED OTLIFT FOR USE WITH NEW POST.
-!! 98-06-18 T BLACK - CONVERSION FROM 1-D TO 2-D
-!! 00-01-04 JIM TUCCILLO - MPI VERSION
-!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT
-!! 02-06-11 MIKE BALDWIN - WRF VERSION
-!! 11-04-12 GEOFF MANIKIN - USE VIRTUAL TEMPERATURE
-!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE
-!!
-!! USAGE: CALL OTLIFT(SLINDX)
-!! INPUT ARGUMENT LIST:
-!!
-!! OUTPUT ARGUMENT LIST:
-!! SLINDX - LIFTED INDEX.
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! NONE
-!! LIBRARY:
-!! COMMON - CTLBLK
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
+!> @brief otlift() computes SFC to 500mb lifted index.
+!>
+!> This routine computes a surface to 500mb lifted index.
+!> The lifted parcel is from the first atmpspheric ETA
+!> layer (ie, the ETA layer closest to the model ground).
+!> The lifted index is the difference between this parcel's
+!> temperature at 500mb and the ambient 500mb temperature.
+!>
+!> @param[out] SLINDX lifted index.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> ????-??-?? | ??? | Subroutine OTLIFT in ETA model.
+!> 1993-03-10 | Russ Treadon | Adapted OTLIFT for use with new post.
+!> 1998-06-18 | T Black | Conversion from 1-D to 2-D
+!> 2000-01-04 | Jim Tuccillo | MPI Version
+!> 2001-10-25 | H Chuang | Modified to process hybrid model output
+!> 2002-06-11 | Mike Baldwin | WRF Version
+!> 2011-04-12 | Geoff Manikin | Use virtual temperature
+!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS Module
+!> 2021-09-30 | JESSE MENG | 2D DECOMPOSITION
+!>
+!> @author Russ Treadon W/NP2 @date 1993-03-10
SUBROUTINE OTLIFT(SLINDX)
!
@@ -47,7 +31,7 @@ SUBROUTINE OTLIFT(SLINDX)
use masks, only: LMH
use lookup_mod, only: THL, RDTH, JTB, QS0, SQS, RDQ,ITB, PTBL, PL, &
RDP, THE0, STHE, RDTHE, TTBL
- use ctlblk_mod, only: JSTA, JEND, IM, SPVAL
+ use ctlblk_mod, only: JSTA, JEND, IM, SPVAL, ISTA, IEND
use params_mod, only: D00,H10E5, CAPA, ELOCP, EPS, ONEPS
use upp_physics, only: FPVSNEW
!
@@ -60,7 +44,7 @@ SUBROUTINE OTLIFT(SLINDX)
!
! DECLARE VARIABLES.
- real,intent(out) :: SLINDX(IM,jsta:jend)
+ real,intent(out) :: SLINDX(ista:iend,jsta:jend)
REAL :: TVP, ESATP, QSATP
REAL :: TTH, TP, APESP, PARTMP, THESP, TPSP
REAL :: BQS00, SQS00, BQS10, SQS10, BQ, SQ, TQ
@@ -77,13 +61,13 @@ SUBROUTINE OTLIFT(SLINDX)
! INTIALIZE LIFTED INDEX ARRAY TO ZERO.
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
SLINDX(I,J) = D00
ENDDO
ENDDO
!--------------FIND EXNER AT LOWEST LEVEL-------------------------------
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
LBTM=NINT(LMH(I,J))
IF(T(I,J,LBTM) @file
-!
-!> SUBPROGRAM: PARA_RANGE SET UP DECOMPOSITION VALUES
-!! PRGRMMR: TUCCILLO ORG: IBM
-!!
-!! ABSTRACT:
-!! SETS UP DECOMOSITION VALUES
-!!
-!! PROGRAM HISTORY LOG:
-!! 00-01-06 TUCCILLO - ORIGINAL
+!> @brief para_range() sets up decomposition values.
+!>
+!> This subroutine sets up decomposition values.
+!>
+!> @param[in] N1 First interate value.
+!> @param[in] N2 Last interate value.
+!> @param[in] NPROCS Number of MPI tasks.
+!> @param[in] IRANK My taks ID.
+!> @param[out] ISTA First loop value.
+!> @param[out] IEND Last loop value.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2000-01-06 | Jim Tuccillo | Initial
+!>
+!> @author Jim Tuccillo IBM @date 2000-01-06
+ SUBROUTINE PARA_RANGE (N1,N2,NPROCS,IRANK,ISTA,IEND)
+
+ implicit none
+ integer,intent(in) :: n1,n2,nprocs,irank
+ integer,intent(out) :: ista,iend
+ integer iwork1, iwork2
+
+ iwork1 = ( n2 - n1 + 1 ) / nprocs
+ iwork2 = mod ( n2 - n1 + 1, nprocs )
+ ista = irank * iwork1 + n1 + min ( irank, iwork2 )
+ iend = ista + iwork1 - 1
+ if ( iwork2 > irank ) iend = iend + 1
+ return
+ end
!!
-!! USAGE: CALL PARA_RANGE (N1,N2,NPROCS,IRANK,ISTA,IEND)(A)
+!! USAGE: CALL PARA_RANGE2(N1,N2,NX,NY,NRANK,ISTA,IEND,JSTA,JEND)(A)
!! INPUT ARGUMENT LIST:
-!! N1 - FIRST INTERATE VALUE
-!! N2 - LAST INTERATE VALUE
-!! NPROCS - NUMBER OF MPI TASKS
-!! IRANK - MY TAKS ID
+!! N1 - LAAT INTERATE VALUE I dimension
+!! N2 - LAST INTERATE VALUE J dimension
+!! NX NUMBER OF subdomains in Z dimension
+!! NY NUMBER OF subdomains in Y dimension
+!! NX * NY should be the total number of MPI procs
+!! NRANK - MY TAKS ID
!!
!! OUTPUT ARGUMENT LIST:
-!! ISTA - FIRST LOOP VALUE
-!! IEND - LAST LOOP VALUE
+!! ISTA - FIRST LOOP VALUE I
+!! IEND - LAST LOOP VALUE I
+!! JSTA - FIRST LOOP VALUE J
+!! JEND - LAST LOOP VALUE J
!!
!! OUTPUT FILES:
!! STDOUT - RUN TIME STANDARD OUT.
@@ -32,18 +58,20 @@
!! LANGUAGE: FORTRAN
!! MACHINE : IBM RS/6000 SP
!!
- SUBROUTINE PARA_RANGE (N1,N2,NPROCS,IRANK,ISTA,IEND)
+ subroutine para_range2(im,jm,nx,ny,nrank,ista,iend,jsta,jend)
implicit none
- integer,intent(in) :: n1,n2,nprocs,irank
- integer,intent(out) :: ista,iend
- integer iwork1, iwork2
+ integer,intent(in) :: im,jm,nx,ny,nrank
+ integer,intent(out) :: ista,iend,jsta,jend
+ integer :: ix,jx
+
+ jx=nrank/nx
+ ix=nrank-(jx*nx)
+ call para_range(1,im,nx,ix,ista,iend)
+ call para_range(1,jm,ny,jx,jsta,jend)
+! print 101,n,ix,jx,ista,iend,jsta,jend
+! 101 format(16i8)
+ return
+ end
- iwork1 = ( n2 - n1 + 1 ) / nprocs
- iwork2 = mod ( n2 - n1 + 1, nprocs )
- ista = irank * iwork1 + n1 + min ( irank, iwork2 )
- iend = ista + iwork1 - 1
- if ( iwork2 > irank ) iend = iend + 1
- return
- end
diff --git a/sorc/ncep_post.fd/PROCESS.f b/sorc/ncep_post.fd/PROCESS.f
index 034de6caf..64c9c35de 100644
--- a/sorc/ncep_post.fd/PROCESS.f
+++ b/sorc/ncep_post.fd/PROCESS.f
@@ -1,53 +1,30 @@
!> @file
-!
-!> SUBPROGRAM: PROCESS DRIVER FOR MAJOR POST ROUTINES.
-!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-21
-!!
-!! ABSTRACT:
-!! THIS ROUTINE CALLS THE MAJOR POST PROCESSOR ROUTINES.
-!! THESE ROUTINES ARE
-!! MDLFLD - CALCULATE NMC SLP, SET BELOW SURFACE FIELDS,
-!! AND POSTS DATA ON MODEL SURFACES.
-!! MDL2P - POSTS DATA ON ISOBARIC SURFACES.
-!! SURFCE - POSTS SOUNDING DATA, SURFACE BASED FIELDS,
-!! AND STATIC OR FIXED FIELDS.
-!! CLDRAD - POST SOUNDING/CLOUD/RADIATION FIELDS.
-!! MISCLN - POST MISCELLANEOUS (SPECIAL) FIELDS.
-!! FIXED - POST FIXED FIELDS.
-!!
-!! PROGRAM HISTORY LOG:
-!! 92-12-21 RUSS TREADON
-!! 98-06-01 T BLACK - CONVERSION OF POST FROM 1-D TO 2-D
-!! 00-01-05 JIM TUCCILLO - MPI VERSION
-!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT
-!! 02-06-19 MIKE BALDWIN - WRF VERSION
-!! 11-02-04 Jun Wang - add grib2 option
-!!
-!! USAGE: CALL PROCESS
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! MDLFLD - POST DATA MDL SURFACES.
-!! MDL2P - POST DATA ON PRESSURE SURFACES.
-!! SURFCE - POST SURFACE BASED FIELDS.
-!! CLDRAD - POST SOUNDING/CLOUD/RADIATION FIELDS.
-!! MISCLN - POST MISCELLANEOUS FIELDS.
-!! FIXED - POST FIXED FIELDS.
-!! LIBRARY:
-!! COMMON - OUTGRD
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
+!> @brief process() is a driver for major post routines.
+!>
+!> This routine calls the major post processor routines.
+!>
+!> These routines are
+!> MDLFLD - Calculate NMC SLP, set below surface fields,
+!> and posts data on model surfaces.
+!> MDL2P - Posts data on isobaric surfaces.
+!> SURFCE - Posts sounding data surface based fields,
+!> and static or fixed fields.
+!> CLDRAD - Post sounding/cloud/radiation fields.
+!> MISCLN - Post miscellaneous (special) fields.
+!> FIXED - Post fixed fields.
+!>
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1992-12-21 | Russ Treadon | Initial
+!> 1998-06-01 | T Black | Conversion from 1-D to 2-D
+!> 2000-01-05 | Jim Tuccillo | MPI Version
+!> 2001-10-25 | H CHUANG | Modified to process hybrid model output
+!> 2002-06-19 | Mike Baldwin | WRF Version
+!> 2011-02-04 | Jun Wang | Add grib2 option
+!>
+!> @author Russ Treadon W/NP2 @date 1992-12-21
SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D)
!
!----------------------------------------------------------------------------
@@ -76,37 +53,45 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D)
! START SUBROUTINE PROCESS.
!
cfld=0
+ if(me==0) write(0,*) "PROCESS starts"
!
! COMPUTE/POST FIELDS ON MDL SURFACES.
!
btim = mpi_wtime()
CALL MDLFLD
+ if(me==0) write(0,*) "PROCESS MDLFLD done"
ETAFLD2_tim = ETAFLD2_tim +(mpi_wtime() - btim)
!
! COMPUTE/POST FIELDS ON PRESSURE SURFACES.
btim = mpi_wtime()
CALL MDL2P(iostatusD3D)
+ if(me==0) write(0,*) "PROCESS MDL2P done"
ETA2P_tim = ETA2P_tim +(mpi_wtime() - btim)
!
! COMPUTE/POST FIELDS ON SIGMA SURFACES.
btim = mpi_wtime()
CALL MDL2SIGMA
+ if(me==0) write(0,*) "PROCESS MDL2SIGMA done"
CALL MDL2SIGMA2
+ if(me==0) write(0,*) "PROCESS MDL2SIGMA2 done"
MDL2SIGMA_tim = MDL2SIGMA_tim +(mpi_wtime() - btim)
!
! COMPUTE/POST FIELDS ON AGL SURFCES.
btim = mpi_wtime()
CALL MDL2AGL
+ if(me==0) write(0,*) "PROCESS MDL2AGL done"
MDL2AGL_tim = MDL2AGL_tim +(mpi_wtime() - btim)
!
! COMPUTE/POST SURFACE RELATED FIELDS.
btim = mpi_wtime()
CALL SURFCE
+ if(me==0) write(0,*) "PROCESS SURFCE done"
SURFCE2_tim = SURFCE2_tim +(mpi_wtime() - btim)
!
! COMPUTE/POST SOUNDING AND CLOUD RELATED FIELDS.
btim = mpi_wtime()
CALL CLDRAD
+ if(me==0) write(0,*) "PROCESS CLDRAD done"
CLDRAD_tim = CLDRAD_tim +(mpi_wtime() - btim)
!
! COMPUTE/POST TROPOPAUSE DATA, FD LEVEL FIELDS,
@@ -114,6 +99,7 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D)
! AND LFM-NGM LOOK-ALIKE FIELDS.
btim = mpi_wtime()
CALL MISCLN
+ if(me==0) write(0,*) "PROCESS MISCLN done"
MISCLN_tim = MISCLN_tim +(mpi_wtime() - btim)
! COMPUTE/POST TROPOPAUSE DATA, FD LEVEL FIELDS,
@@ -121,27 +107,32 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D)
! AND LFM-NGM LOOK-ALIKE FIELDS.
btim = mpi_wtime()
CALL MDL2STD_P
+ if(me==0) write(0,*) "PROCESS MDL2STD_P done"
MDL2STD_tim = MDL2STD_tim +(mpi_wtime() - btim)
!
! POST FIXED FIELDS.
btim = mpi_wtime()
CALL FIXED
+ if(me==0) write(0,*) "PROCESS FIXED done"
FIXED_tim = FIXED_tim +(mpi_wtime() - btim)
!
! COMPUTE/POST FIELDS ON SIGMA SURFACES.
btim = mpi_wtime()
CALL MDL2THANDPV(kth,kpv,th,pv)
+ if(me==0) write(0,*) "PROCESS MDL2THANDPV done"
MDL2THANDPV_tim = MDL2THANDPV_tim +(mpi_wtime() - btim)
!
! POST RADIANCE AND BRIGHTNESS FIELDS.
btim = mpi_wtime()
CALL CALRAD_WCLOUD
+ if(me==0) write(0,*) "PROCESS CALRAD_WCLOUD done"
CALRAD_WCLOUD_tim = CALRAD_WCLOUD_tim +(mpi_wtime() - btim)
!
! END OF ROUTINE.
!
NTLFLD=cfld
if(me==0)print *,'nTLFLD=',NTLFLD
+ if(me==0) write(0,*) "PROCESS done"
!
RETURN
END
diff --git a/sorc/ncep_post.fd/SCLFLD.f b/sorc/ncep_post.fd/SCLFLD.f
index fc4087ea8..4450bb9f4 100644
--- a/sorc/ncep_post.fd/SCLFLD.f
+++ b/sorc/ncep_post.fd/SCLFLD.f
@@ -1,48 +1,34 @@
!> @file
-!
-!> SUBPROGRAM: SCLFLD SCALE ARRAY ELEMENT BY CONSTANT
-!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-09-13
-!!
-!! ABSTRACT:
-!! THIS ROUTINE MULTIPLES (SCALES) THE FIRST IMO*JMO
-!! ELEMENTS OF ARRAY FLD BY THE REAL SCALAR SCALE.
-!! ARRAY ELEMENTS WHICH EQUAL A SPECIAL VALUE WILL
-!! NOT BE SCALED BY SCALE. THEY WILL BE LEFT AS IS.
-!! THE SPECIAL VALUE, SPVAL, IS PASSED THROUGH COMMON
-!! BLOCK OPTIONS. IT IS SET IN INCLUDE FILE OPTIONS.
-!!
-!! PROGRAM HISTORY LOG:
-!! 92-09-13 RUSS TREADON
-!! 00-01-04 JIM TUCCILLO
-!!
-!! USAGE: CALL SCLFLD(FLD,SCALE,IMO,JMO)
-!! INPUT ARGUMENT LIST:
-!! FLD - ARRAY WHOSE ELEMENTS ARE TO BE SCALED.
-!! SCALE - CONSTANT BY WHICH TO SCALE ELEMENTS OF FLD.
-!! IMO,JMO - DIMENSION OF ARRAY FLD.
-!!
-!! OUTPUT ARGUMENT LIST:
-!! FLD - ARRAY WHOSE ELEMENTS HAVE BEEN SCALED BY SCALE.
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! NONE
-!! LIBRARY:
-!! COMMON - OPTIONS
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
+!> @brief sclfld() scale array element by constant.
+!>
+!> @author Russ Treadon W/NP2 @date 1992-09-13
+
+!> This routine multiples (scales) the first IMO*JMO
+!> elements of array fld by the real scalar scale.
+!> Array elements which equal a special value will
+!> not be scaled by scale. They will be left as is.
+!> The special value, spval, is passed through common
+!> block options. It is set in include file options.
+!>
+!> @param[in] FLD Array whose elements are to be scaled.
+!> @param[in] SCALE Constant by which to scale elements of fld.
+!> @param[in] IMO,JMO Dimension of array fld.
+!> @param[out] FLD Array whose elements have been scaled by scale.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1992-09-13 | Russ Treadon | Initial
+!> 2000-01-04 | Jim Tuccillo | MPI Version
+!> 2021-09-29 | JESSE MENG | 2D DECOMPOSITION
+!>
+!> @author Russ Treadon W/NP2 @date 1992-09-13
SUBROUTINE SCLFLD(FLD,SCALE,IMO,JMO)
!
!
use params_mod, only: small
- use ctlblk_mod, only: jsta, jend, spval
+ use ctlblk_mod, only: jsta, jend, spval, ista, iend
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
!
@@ -50,7 +36,7 @@ SUBROUTINE SCLFLD(FLD,SCALE,IMO,JMO)
!
integer,intent(in) :: IMO,JMO
REAL,intent(in) :: SCALE
- REAL,dimension(imo,jmo),intent(inout) :: FLD
+ REAL,dimension(ista:iend,jsta:jend),intent(inout) :: FLD
integer I,J
!
!
@@ -61,7 +47,7 @@ SUBROUTINE SCLFLD(FLD,SCALE,IMO,JMO)
!
!$omp parallel do
DO J=JSTA,JEND
- DO I=1,IMO
+ DO I=ISTA,IEND
IF(ABS(FLD(I,J)-SPVAL)>SMALL) FLD(I,J)=SCALE*FLD(I,J)
ENDDO
ENDDO
diff --git a/sorc/ncep_post.fd/SELECT_CHANNELS.f b/sorc/ncep_post.fd/SELECT_CHANNELS.f
index f78828044..8964566a0 100644
--- a/sorc/ncep_post.fd/SELECT_CHANNELS.f
+++ b/sorc/ncep_post.fd/SELECT_CHANNELS.f
@@ -1,27 +1,21 @@
!> @file
-!
-!> SELECT_CHANNEL
-!! @author HWRF @date 20120927
-!!
-!! Verify channel information and print error to output file if
-!! detected, finally excuting a program STOP - which may cause
-!! a hang condifition if run on multiple processors.
-!! If data passed validation the channel indices passed in via
-!! the "channels" array are stored in the structure defining
-!! the channel object
-!!
-!! @param[inout] channelinfo - structure defining channel object
-!! @param[in] nchannels - number of channels for sensor
-!! @param[in] channels
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES: NONE
-!!
-!! LIBRARY: NONE
-!!
+!> @brief select_channels() verifies channel information.
+!>
+!> @author HWRF @date 2012-09-27
+
+!> This subroutine verifies channel information and print error to output file if
+!> detected, finally excuting a program STOP - which may cause
+!> a hang condifition if run on multiple processors.
+!>
+!> If data passed validation the channel indices passed in via
+!> the "channels" array are stored in the structure defining
+!> the channel object.
+!>
+!> @param[inout] channelinfo structure defining channel object.
+!> @param[in] nchannels number of channels for sensor.
+!> @param[in] channels.
+!>
+!> @author HWRF @date 2012-09-27
subroutine SELECT_CHANNELS(channelinfo,nchannels,channels)
use crtm_channelinfo_define, only: crtm_channelinfo_type
diff --git a/sorc/ncep_post.fd/SETUP_SERVERS.f b/sorc/ncep_post.fd/SETUP_SERVERS.f
index 9f2a2b084..8acd4332b 100644
--- a/sorc/ncep_post.fd/SETUP_SERVERS.f
+++ b/sorc/ncep_post.fd/SETUP_SERVERS.f
@@ -1,56 +1,22 @@
!> @file
-! . . .
-!> SUBROUTINE: SETUP_SERVERS SETUP I/O SERVERS
-!! PRGRMMR: TUCCILLO ORG: IBM DATE: 00-03-20
-!!
-!! ABSTRACT: SETUP I/O SERVERS
-!!
-!! PROGRAM HISTORY LOG:
-!! 00-03-11 TUCCILLO - ORIGINATOR
-!!
-!! USAGE: CALL SETUP_SERVERS(MYPE,
-!! * NPES,
-!! * INUMQ,
-!! * MPI_COMM_COMP,
-!! * MPI_COMM_INTER)
-!!
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! MYPE - MY RANK
-!! INUMQ - ARRAY THAT HOLDS THE NUMBER OF SERVERS IN EACH GROUP
-!! NPES - NUMBER OF MPI TASKS FOR POSTING
-!! MPI_COMM_COMP - THE NEW INTRACOMMUNICATOR FOR ALL TASKS
-!! MPI_COMM_INTER - THE INTERCOMMUNICATOR FOR THE I/O SERVERS
-!!
-!! INPUT FILES: NONE
-!!
-!! OUTPUT FILES:
-!!
-!! SUBPROGRAMS CALLED:
-!! UNIQUE:
-!! PARA_RANGE
-!! MPI_INIT
-!! MPI_COMM_RANK
-!! MPI_COMM_SIZE
-!! MPI_COMM_DUP
-!! MPI_COMM_SPLIT
-!! MPI_COMM_GROUP
-!! MPI_GROUP_EXCL
-!! MPI_COMM_CREATE
-!! MPI_GROUP_FREE
-!! MPI_INTERCOMM_CREATE
-!! MPI_BARRIER
-!!
-!! EXIT STATES:
-!! COND = 0 - NORMAL EXIT
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN 90
-!! MACHINE : IBM SP
-!!
-!!
+!> @brief setup_servers() setups I/O servers.
+!>
+!> @author Jim Tuccillo IBM @date 2000-03-20
+
+!> This subroutine is to setup I/O servers.
+!>
+!> @param[out] MYPE My rank.
+!> @param[out] INUMQ Array that holds the number of servers in each group.
+!> @param[out] NPES Number of MPI tasks for posting.
+!> @param[out] MPI_COMM_COMP The new intracommunicator for all tasks.
+!> @param[out] MPI_COMM_INTER The intercommunicator for the I/O servers.
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2000-03-20 | Jim Tuccillo | Initial
+!>
+!> @author Jim Tuccillo IBM @date 2000-03-20
SUBROUTINE SETUP_SERVERS(MYPE, &
& NPES, &
& INUMQ, &
diff --git a/sorc/ncep_post.fd/SET_OUTFLDS.f b/sorc/ncep_post.fd/SET_OUTFLDS.f
index a12d60106..a21f98fa5 100644
--- a/sorc/ncep_post.fd/SET_OUTFLDS.f
+++ b/sorc/ncep_post.fd/SET_OUTFLDS.f
@@ -1,43 +1,25 @@
!> @file
-! . . .
-!> SUBPROGRAM: READCNTRLgrb2_xml READS POST xml CONTROL FILE
-!! PRGRMMR: J. WANG ORG: NCEP/EMC DATE: 12-01-27
-!!
-!! ABSTRACT:
-!! THIS ROUTINE READS THE CONTROL FILE IN XML FORMAT SPECIFYING
-!! FIELD(S) TO POST, AND SAVE ALL THE FIELD INFORMATION IN
-!! A DATATYPE array PSET
-!!
-!! PROGRAM HISTORY LOG:
-!! 01_27_2012 Jun Wang - INITIAL CODE
-!! 03_10_2015 Lin Gan - Replace XML file with flat file implementation
-!! 10_30_2019 Bo CUI - REMOVE "GOTO" STATEMENT
+!> @ brief set_outflds() reads post xml control file.
+!>
+!> @author J. Wang NCEP/EMC @date 2012-01-27
-!!
-!! USAGE: CALL READCNTRL_XML(kth,kpv,pv,th)
-!! INPUT ARGUMENT LIST:
-!! KTH
-!! TH
-!! KPV
-!! PV
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE -
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!!
-!! LIBRARY:
-!! COMMON - RQSTFLDGRB2
-!! CTLBLK
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : IBM
-!!
+!> This routine reads the control file in xml format specifying
+!> field(s) to post, and save all the field information in
+!> a datatype array PSET.
+!>
+!> @param[in] KTH
+!> @param[in] TH
+!> @param[in] KPV
+!> @param[in] PV
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2012-01-27 | Jun Wang | Initial
+!> 2015-03-10 | Lin Gan | Replace XML file with flat file implementation
+!> 2019-10-30 | Bo Cui | Removw "GOTO" Statement
+!>
+!> @author J. Wang NCEP/EMC @date 2012-01-27
SUBROUTINE SET_OUTFLDS(kth,th,kpv,pv)
!
diff --git a/sorc/ncep_post.fd/SLP_NMM.f b/sorc/ncep_post.fd/SLP_NMM.f
deleted file mode 100644
index 9c8a3669e..000000000
--- a/sorc/ncep_post.fd/SLP_NMM.f
+++ /dev/null
@@ -1,411 +0,0 @@
- SUBROUTINE MEMSLP_NMM(TPRES,QPRES,FIPRES)
-!
-!$$$ SUBPROGRAM DOCUMENTATION BLOCK
-! . . .
-! SUBROUTINE: MEMSLP MEMBRANE SLP REDUCTION
-!
-! ABSTRACT: THIS ROUTINE COMPUTES THE SEA LEVEL PRESSURE
-! REDUCTION USING THE MESINGER RELAXATION
-! METHOD FOR SIGMA COORDINATES.
-! A BY-PRODUCT IS THE
-! SET OF VALUES FOR THE UNDERGROUND TEMPERATURES
-! ON THE SPECIFIED PRESSURE LEVELS
-!
-! PROGRAM HISTORY LOG:
-! 99-09-23 T BLACK - REWRITTEN FROM ROUTINE SLP (ETA
-! COORDINATES)
-! 02-07-26 H CHUANG - PARALLIZE AND MODIFIED FOR WRF A/C GRIDS
-! ALSO REDUCE S.O.R. COEFF FROM 1.75 to 1.25
-! BECAUSE THERE WAS NUMERICAL INSTABILITY
-! 02-08-21 H CHUANG - MODIFIED TO ALWAYS USE OLD TTV FOR RELAXATION
-! SO THAT THERE WAS BIT REPRODUCIBILITY BETWEEN
-! USING ONE AND MULTIPLE TASKS
-! 13-12-06 H CHUANG - REMOVE EXTRA SMOOTHING OF SLP AT THE END
-! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT
-!
-! USAGE: CALL SLPSIG FROM SUBROUITNE ETA2P
-!
-! INPUT ARGUMENT LIST:
-! PD - SFC PRESSURE MINUS PTOP
-! FIS - SURFACE GEOPOTENTIAL
-! T - TEMPERATURE
-! Q - SPECIFIC HUMIDITY
-! FI - GEOPOTENTIAL
-! PT - TOP PRESSURE OF DOMAIN
-!
-! OUTPUT ARGUMENT LIST:
-! PSLP - THE FINAL REDUCED SEA LEVEL PRESSURE ARRAY
-!
-! SUBPROGRAMS CALLED:
-! UNIQUE:
-! NONE
-!
-!-----------------------------------------------------------------------
- use vrbls3d, only: pint, zint, t, q
- use vrbls2d, only: pslp, fis
- use masks, only: lmh
- use params_mod, only: overrc, ad05, cft0, g, rd, d608, h1, kslpd
- use ctlblk_mod, only: jsta, jend, spl, num_procs, mpi_comm_comp, lsmp1, jsta_m2, jend_m2,&
- lm, jsta_m, jend_m, im, jsta_2l, jend_2u, im_jm, lsm, jm
-!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- implicit none
-!
- INCLUDE "mpif.h"
-!-----------------------------------------------------------------------
- integer, PARAMETER :: NFILL=0,NRLX1=500,NRLX2=100
-!-----------------------------------------------------------------------
- real,dimension(IM,JSTA_2L:JEND_2U,LSM),intent(in) :: QPRES
- real,dimension(IM,JSTA_2L:JEND_2U,LSM),intent(inout) :: TPRES,FIPRES
- REAL :: TTV(IM,JSTA_2L:JEND_2U),TNEW(IM,JSTA_2L:JEND_2U) &
- ,SLPX(IM,JSTA_2L:JEND_2U) &
- ,P1(IM,JSTA_2L:JEND_2U),HTM2D(IM,JSTA_2L:JEND_2U)
- REAL :: HTMO(IM,JSTA_2L:JEND_2U,LSM)
- real P2,GZ1,GZ2,TLYR,SPLL,PCHK,PSFC,SLOPE,TVRT,DIS,TINIT
-!-----------------------------------------------------------------------
-!-----------------------------------------------------------------------
- INTEGER :: KMNTM(LSM),IMNT(IM_JM,LSM),JMNT(IM_JM,LSM) &
- ,LMHO(IM,JSTA_2L:JEND_2U)
- INTEGER :: IHE(JM),IHW(JM),IVE(JM),IVW(JM),IHS(JM),IHN(JM)
- integer ii,jj,I,J,L,N,KM,KS,KP,KMN,KMM,KOUNT,LP,LLMH,LHMNT &
- ,LMHIJ,LMAP1,LXXX,IERR,NRLX,IHH2
-!-----------------------------------------------------------------------
- LOGICAL :: DONE(IM,JSTA_2L:JEND_2U)
- logical, parameter :: debugprint = .false.
-!-----------------------------------------------------------------------
-!-----------------------------------------------------------------------
-!***
-!*** CALCULATE THE I-INDEX EAST-WEST INCREMENTS
-!***
-!
- ii=279
- jj=314
- DO J=1,JM
- IHE(J)=MOD(J+1,2)
- IHW(J)=IHE(J)-1
- ENDDO
-! print*,'relaxation coeff= ',OVERRC
-!-----------------------------------------------------------------------
-!***
-!*** INITIALIZE ARRAYS. LOAD SLP ARRAY WITH SURFACE PRESSURE.
-!***
-!$omp parallel do
- DO J=JSTA,JEND
- DO I=1,IM
- LLMH=NINT(LMH(I,J))
- PSLP(I,J)=PINT(I,J,LLMH+1)
- if(debugprint .and. i==ii .and. j==jj)print*,'Debug: FIS,IC for PSLP=' &
- ,FIS(i,j),PSLP(I,J)
- TTV(I,J)=0.
- LMHO(I,J)=0
- DONE(I,J)=.FALSE.
- ENDDO
- ENDDO
-!
-!*** CALCULATE SEA LEVEL PRESSURE FOR PROFILES (AND POSSIBLY
-!*** FOR POSTING BY POST PROCESSOR).
-!
-!--------------------------------------------------------------------
-!***
-!*** CREATE A 3-D "HEIGHT MASK" FOR THE SPECIFIED PRESSURE LEVELS
-!*** (1 => ABOVE GROUND) AND A 2-D INDICATOR ARRAY THAT SAYS
-!*** WHICH PRESSURE LEVEL IS THE LOWEST ONE ABOVE THE GROUND
-!***
- DO 100 L=1,LSM
- SPLL=SPL(L)
-!
- DO J=JSTA,JEND
- DO I=1,IM
- PSFC=PSLP(I,J)
- PCHK=PSFC
- IF(NFILL>0)THEN
- PCHK=PINT(I,J,NINT(LMH(I,J))+1-NFILL)
- ENDIF
-! IF(SM(I,J)>0.5.AND.FIS(I,J)<1.)PCHK=PSLP(I,J)
- IF(FIS(I,J)<1.)PCHK=PSLP(I,J)
-!
-! IF(SPLL1.AND.HTMO(I,J,L-1)>0.5)LMHO(I,J)=L-1
- ENDIF
-!
- IF(L==LSM.AND.HTMO(I,J,L)>0.5)LMHO(I,J)=LSM
- if(debugprint .and. i==ii .and. j==jj)print*,'Debug: HTMO= ',HTMO(I,J,L)
- ENDDO
- ENDDO
-!
- 100 CONTINUE
-! if(jj>=jsta.and.jj<=jend)
-! +print*,'Debug: LMHO=',LMHO(ii,jj)
-!--------------------------------------------------------------------
-!***
-!*** WE REACH THIS LINE IF WE WANT THE MESINGER ETA SLP REDUCTION
-!*** BASED ON RELAXATION TEMPERATURES. THE FIRST STEP IS TO
-!*** FIND THE HIGHEST LAYER CONTAINING MOUNTAINS.
-!***
- loop210: DO L=LSM,1,-1
-!
- DO J=JSTA,JEND
- DO I=1,IM
- IF(HTMO(I,J,L)<0.5) cycle loop210
- ENDDO
- ENDDO
-!
- LHMNT=L+1
- exit loop210
- enddo loop210
-
- if(debugprint)print*,'Debug in SLP: LHMNT=',LHMNT
- if ( num_procs > 1 ) then
- CALL MPI_ALLREDUCE &
- (LHMNT,LXXX,1,MPI_INTEGER,MPI_MIN,MPI_COMM_COMP,IERR)
- LHMNT = LXXX
- end if
-
- IF(LHMNT==LSMP1)THEN
- GO TO 325
- ENDIF
- if(debugprint)print*,'Debug in SLP: LHMNT A ALLREDUCE=',LHMNT
-!***
-!*** NOW GATHER THE ADDRESSES OF ALL THE UNDERGROUND POINTS.
-!***
-!$omp parallel do private(kmn,kount)
- DO 250 L=LHMNT,LSM
- KMN=0
- KMNTM(L)=0
- KOUNT=0
- DO 240 J=JSTA_M2,JEND_M2
-! DO 240 J=JSTA_M,JEND_M
- DO 240 I=2,IM-1
- KOUNT=KOUNT+1
- IMNT(KOUNT,L)=0
- JMNT(KOUNT,L)=0
- IF(HTMO(I,J,L)>0.5) CYCLE
- KMN=KMN+1
- IMNT(KMN,L)=I
- JMNT(KMN,L)=J
- 240 CONTINUE
- KMNTM(L)=KMN
- 250 CONTINUE
-!
-!
-!*** CREATE A TEMPORARY TV ARRAY, AND FOLLOW BY SEQUENTIAL
-!*** OVERRELAXATION, DOING NRLX PASSES.
-!
-! IF(NTSD==1)THEN
- NRLX=NRLX1
-! ELSE
-! NRLX=NRLX2
-! ENDIF
-!
-!!$omp parallel do private(i,j,tinit,ttv)
- DO 300 L=LHMNT,LSM
-!
- DO 270 J=JSTA,JEND
- DO 270 I=1,IM
- TTV(I,J)=TPRES(I,J,L)
- IF(TTV(I,J)<150. .and. TTV(I,J)>325.0)print* &
- ,'abnormal IC for T relaxation',i,j,TTV(I,J)
- HTM2D(I,J)=HTMO(I,J,L)
- 270 CONTINUE
-!
-!*** FOR GRID BOXES NEXT TO MOUNTAINS, COMPUTE TV TO USE AS
-!*** BOUNDARY CONDITIONS FOR THE RELAXATION UNDERGROUND
-!
- CALL EXCH2(HTM2D(1,JSTA_2L)) !NEED TO EXCHANGE TWO ROW FOR E GRID
- DO J=JSTA_M2,JEND_M2
- DO I=2,IM-1
- IF(HTM2D(I,J)>0.5.AND.HTM2D(I+IHW(J),J-1)*HTM2D(I+IHE(J),J-1) &
- *HTM2D(I+IHW(J),J+1)*HTM2D(I+IHE(J),J+1) &
- *HTM2D(I-1 ,J )*HTM2D(I+1 ,J ) &
- *HTM2D(I ,J-2)*HTM2D(I ,J+2)<0.5)THEN
-!HC MODIFICATION FOR C AND A GRIDS
-!HC IF(HTM2D(I,J)>0.5.AND.
-!HC 1 HTM2D(I-1,J)*HTM2D(I+1,J)
-!HC 2 *HTM2D(I,J-1)*HTM2D(I,J+1)
-!HC 3 *HTM2D(I-1,J-1)*HTM2D(I+1,J-1)
-!HC 4 *HTM2D(I-1,J+1)*HTM2D(I+1,J+1)<0.5)THEN
-!
- TTV(I,J)=TPRES(I,J,L)*(1.+0.608*QPRES(I,J,L))
- ENDIF
-! if(i==ii.and.j==jj)print*,'Debug:L,TTV B SMOO= ',l,TTV(I,J)
- ENDDO
- ENDDO
-!
- KMM=KMNTM(L)
-!
- DO 285 N=1,NRLX
- CALL EXCH2(TTV(1,JSTA_2L))
-! print*,'Debug:L,KMM=',L,KMM
- DO 280 KM=1,KMM
- I=IMNT(KM,L)
- J=JMNT(KM,L)
- TINIT=TTV(I,J)
- TNEW(I,J)=AD05*(4.*(TTV(I+IHW(J),J-1)+TTV(I+IHE(J),J-1) &
- +TTV(I+IHW(J),J+1)+TTV(I+IHE(J),J+1)) &
- +TTV(I-1,J) +TTV(I+1,J) &
- +TTV(I,J-2) +TTV(I,J+2)) &
- -CFT0*TTV(I,J)
-!HC MODIFICATION FOR C AND A GRIDS
-! eight point relaxation using old TTV
-!HC TNEW(I,J)=AD05*(4.*(TTV(I-1,J)+TTV(I+1,J)
-!HC 1 +TTV(I,J-1)+TTV(I,J+1))
-!HC 2 +TTV(I-1,J-1)+TTV(I+1,J-1)
-!HC 3 +TTV(I-1,J+1)+TTV(I+1,J+1))
-!HC 4 -CFT0*TTV(I,J)
-!
-! if(i==ii.and.j==jj)print*,'Debug: L,TTV A S'
-! 1,l,TTV(I,J),N
-! 1,l,TNEW(I,J),N
- 280 CONTINUE
-!
- DO KM=1,KMM
- I=IMNT(KM,L)
- J=JMNT(KM,L)
- TTV(I,J)=TNEW(I,J)
- END DO
- 285 CONTINUE
-!
- DO 290 KM=1,KMM
- I=IMNT(KM,L)
- J=JMNT(KM,L)
- TPRES(I,J,L)=TTV(I,J)
- 290 CONTINUE
- 300 CONTINUE
-!----------------------------------------------------------------
-!***
-!*** CALCULATE THE SEA LEVEL PRESSURE AS PER THE NEW SCHEME.
-!*** INTEGRATE THE HYDROSTATIC EQUATION DOWNWARD FROM THE
-!*** GROUND THROUGH EACH OUTPUT PRESSURE LEVEL (WHERE TV
-!*** IS NOW KNOWN) TO FIND GZ AT THE NEXT MIDPOINT BETWEEN
-!*** PRESSURE LEVELS. WHEN GZ=0 IS REACHED, SOLVE FOR THE
-!*** PRESSURE.
-!***
-!
-!*** COUNT THE POINTS WHERE SLP IS DONE BELOW EACH OUTPUT LEVEL
-!
- KOUNT=0
- DO J=JSTA,JEND
- DO I=1,IM
-! P1(I,J)=SPL(NINT(LMH(I,J)))
-! DONE(I,J)=.FALSE.
- IF(abs(FIS(I,J))<1.)THEN
- PSLP(I,J)=PINT(I,J,NINT(LMH(I,J))+1)
- DONE(I,J)=.TRUE.
- KOUNT=KOUNT+1
- if(i==ii.and.j==jj)print*,'Debug:DONE,PSLP A S1=' &
- ,done(i,j),PSLP(I,J)
- ELSE IF(FIS(I,J)<-1.0) THEN
- DO L=LM,1,-1
- IF(ZINT(I,J,L)>0.)THEN
- PSLP(I,J)=PINT(I,J,L)/EXP(-ZINT(I,J,L)*G &
- /(RD*T(I,J,L)*(Q(I,J,L)*D608+1.0)))
- DONE(I,J)=.TRUE.
- if(debugprint .and. i==ii.and.j==jj)print* &
- ,'Debug:DONE,PINT,PSLP A S1=' &
- ,done(i,j),PINT(I,J,L),PSLP(I,J)
- EXIT
- END IF
- END DO
- ENDIF
- ENDDO
- ENDDO
-!
- KMM=KMNTM(LSM)
-!$omp parallel do private(gz1,gz2,i,j,lmap1,p1,p2),shared(pslp)
-
-LOOP320: DO KM=1,KMM
- I=IMNT(KM,LSM)
- J=JMNT(KM,LSM)
- IF(DONE(I,J)) CYCLE
- LMHIJ=LMHO(I,J)
- GZ1=FIPRES(I,J,LMHIJ)
- P1(I,J)=SPL(LMHIJ)
-!
- LMAP1=LMHIJ+1
- DO L=LMAP1,LSM
- P2=SPL(L)
- TLYR=0.5*(TPRES(I,J,L)+TPRES(I,J,L-1))
- GZ2=GZ1+RD*TLYR*ALOG(P1(I,J)/P2)
- FIPRES(I,J,L)=GZ2
-! if(i==ii.and.j==jj)print*,'Debug:L,FI A S2=',L,GZ2
- IF(GZ2<=0.)THEN
- PSLP(I,J)=P1(I,J)/EXP(-GZ1/(RD*TPRES(I,J,L-1)))
-! if(i==ii.and.j==jj)print*,'Debug:PSLP A S2=',PSLP(I,J)
- DONE(I,J)=.TRUE.
- KOUNT=KOUNT+1
- CYCLE LOOP320
- ENDIF
- P1(I,J)=P2
- GZ1=GZ2
- ENDDO
-!HC EXPERIMENT
- LP=LSM
- SLOPE=-6.6E-4
- TLYR=TPRES(I,J,LP)-0.5*FIPRES(I,J,LP)*SLOPE
- PSLP(I,J)=spl(lp)/EXP(-FIPRES(I,J,LP)/(RD*TLYR))
- DONE(I,J)=.TRUE.
-! if(i==ii.and.j==jj)print*,'Debug:spl,FI,TLYR,PSLPA3=' &
-! ,spl(lp),FIPRES(I,J,LP),TLYR,PSLP(I,J)
-!HC EXPERIMENT
-ENDDO LOOP320
-!
-!*** WHEN SEA LEVEL IS BELOW THE LOWEST OUTPUT PRESSURE LEVEL,
-!*** SOLVE THE HYDROSTATIC EQUATION BY CHOOSING A TEMPERATURE
-!*** AT THE MIDPOINT OF THE LAYER BETWEEN THAT LOWEST PRESSURE
-!*** LEVEL AND THE GROUND BY EXTRAPOLATING DOWNWARD FROM T ON
-!*** THE LOWEST PRESSURE LEVEL USING THE DT/DFI BETWEEN THE
-!*** LOWEST PRESSURE LEVEL AND THE ONE ABOVE IT.
-!
-! TOTAL=(IM-2)*(JM-4)
-!
-!HC DO 340 LP=LSM,1,-1
-! IF(KOUNT==TOTAL)GO TO 350
-!HC MODIFICATION FOR SMALL HILL HIGH PRESSURE SITUATION
-!HC IF SURFACE PRESSURE IS CLOSER TO SEA LEVEL THAN LWOEST
-!HC OUTPUT PRESSURE LEVEL, USE SURFACE PRESSURE TO DO EXTRAPOLATION
- 325 CONTINUE
- LP=LSM
- DO 330 J=JSTA,JEND
- DO 330 I=1,IM
- if(debugprint .and. i==ii.and.j==jj)print*,'Debug: with 330 loop'
- IF(DONE(I,J)) cycle
- if(debugprint .and. i==ii.and.j==jj)print*,'Debug: still within 330 loop'
-!HC Comment out the following line for situation with terrain
-!HC at boundary (ie FIPRES<0)
-!HC because they were not counted as undergound point for 8 pt
-!HC relaxation
-!HC IF(FIPRES(I,J,LP)<0.)GO TO 330
-! IF(FIPRES(I,J,LP)<0.)THEN
-! DO LP=LSM,1,-1
-! IF (FIPRES(I,J) <= 0)
-
-! IF(FIPRES(I,J,LP)<0..OR.DONE(I,J))GO TO 330
-! SLOPE=(TPRES(I,J,LP)-TPRES(I,J,LP-1))
-! & /(FIPRES(I,J,LP)-FIPRES(I,J,LP-1))
- SLOPE=-6.6E-4
- IF(PINT(I,J,NINT(LMH(I,J))+1)>SPL(LP))THEN
- LLMH=NINT(LMH(I,J))
- TVRT=T(I,J,LLMH)*(H1+D608*Q(I,J,LLMH))
- DIS=ZINT(I,J,LLMH+1)-ZINT(I,J,LLMH)+0.5*ZINT(I,J,LLMH+1)
- TLYR=TVRT-DIS*G*SLOPE
- PSLP(I,J)=PINT(I,J,LLMH+1)*EXP(ZINT(I,J,LLMH+1)*G/(RD*TLYR))
-! if(i==ii.and.j==jj)print*,'Debug:PSFC,zsfc,TLYR,PSLPA3='
-! 1,PINT(I,J,LLMH+1),ZINT(I,J,LLMH+1),TLYR,PSLP(I,J)
- ELSE
- TLYR=TPRES(I,J,LP)-0.5*FIPRES(I,J,LP)*SLOPE
- PSLP(I,J)=spl(lp)/EXP(-FIPRES(I,J,LP)/(RD*TLYR))
- if(debugprint .and. i==ii.and.j==jj)print*,'Debug:spl,FI,TLYR,PSLPA3=' &
- ,spl(lp),FIPRES(I,J,LP),TLYR,PSLP(I,J)
- END IF
- DONE(I,J)=.TRUE.
- KOUNT=KOUNT+1
- 330 CONTINUE
-!HC 340 CONTINUE
-!
- 350 CONTINUE
-!----------------------------------------------------------------
- RETURN
- END
diff --git a/sorc/ncep_post.fd/SLP_new.f b/sorc/ncep_post.fd/SLP_new.f
index e2aa20c0c..ef7a31d75 100644
--- a/sorc/ncep_post.fd/SLP_new.f
+++ b/sorc/ncep_post.fd/SLP_new.f
@@ -27,6 +27,7 @@ SUBROUTINE MEMSLP(TPRES,QPRES,FIPRES)
! ARE COMMENTED OUT FOR NOW
! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT
! 21-07-26 W Meng - Restrict computation from undefined grids
+! 21-07-07 J Meng - 2D DECOMPOSITION
! 21-09-25 W Meng - Further modification for restricting computation
! from undefined grids.
!
@@ -54,7 +55,7 @@ SUBROUTINE MEMSLP(TPRES,QPRES,FIPRES)
use params_mod, only: overrc, ad05, cft0, g, rd, d608, h1, kslpd
use ctlblk_mod, only: jend, jsta, spval, spl, num_procs, mpi_comm_comp, lsmp1, &
jsta_m, jend_m, lm, im, jsta_2l, jend_2u, lsm, jm,&
- im_jm
+ im_jm, iend, ista, ista_m, iend_m, ista_2l, iend_2u
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
!
@@ -63,29 +64,29 @@ SUBROUTINE MEMSLP(TPRES,QPRES,FIPRES)
integer,PARAMETER :: NFILL=0,NRLX1=500,NRLX2=100
real,parameter:: def_of_mountain=2.0
!-----------------------------------------------------------------------
- real,dimension(IM,JSTA_2L:JEND_2U,LSM),intent(in) :: QPRES
- real,dimension(IM,JSTA_2L:JEND_2U,LSM),intent(inout) :: TPRES,FIPRES
- REAL :: TTV(IM,JSTA_2L:JEND_2U),TNEW(IM,JSTA_2L:JEND_2U) &
- , P1(IM,JSTA_2L:JEND_2U),HTM2D(IM,JSTA_2L:JEND_2U)
- REAL :: HTMO(IM,JSTA_2L:JEND_2U,LSM)
+ real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LSM),intent(in) :: QPRES
+ real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LSM),intent(inout) :: TPRES,FIPRES
+ REAL :: TTV(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),TNEW(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U) &
+ , P1(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),HTM2D(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)
+ REAL :: HTMO(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LSM)
real :: P2,TLYR,GZ1,GZ2,SPLL,PSFC,PCHK,SLOPE,TVRTC,DIS,TVRT,tem
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
INTEGER :: KMNTM(LSM),IMNT(IM_JM,LSM),JMNT(IM_JM,LSM) &
- , LMHO(IM,JSTA_2L:JEND_2U)
+ , LMHO(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)
INTEGER :: IHE(JM),IHW(JM),IVE(JM),IVW(JM),IHS(JM),IHN(JM)
integer ii,jj,I,J,L,N,LLMH,KM,KS,IHH2,KOUNT,KMN,NRLX,LHMNT, &
LMHIJ,LMAP1,KMM,LP,LXXX,IERR
! dong
real a1,a2,a3,a4,a5,a6,a7,a8
!-----------------------------------------------------------------------
- LOGICAL :: DONE(IM,JSTA_2L:JEND_2U)
+ LOGICAL :: DONE(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)
!-----------------------------------------------------------------------
!***
!*** CALCULATE THE I-INDEX EAST-WEST INCREMENTS
!***
!
- ii = IM/2
+ ii = (IEND-ISTA)/2
jj = (JEND-JSTA)/2
DO J=1,JM
IHE(J) = 1
@@ -102,7 +103,7 @@ SUBROUTINE MEMSLP(TPRES,QPRES,FIPRES)
!***
!$omp parallel do private(i,j,llmh)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
LLMH = NINT(LMH(I,J))
PSLP(I,J) = PINT(I,J,LLMH+1)
! dong
@@ -127,7 +128,7 @@ SUBROUTINE MEMSLP(TPRES,QPRES,FIPRES)
!
!$omp parallel do private(j,i,psfc,pchk)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
HTMO(I,J,L)=1.
if(PSLP(I,J)0) THEN
- allocate(dwpsfc(im,jsta:jend))
+ allocate(dwpsfc(ista:iend,jsta:jend))
CALL DEWPOINT(EVP,DWPSFC)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(029))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = DWPSFC(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = DWPSFC(ii,jj)
enddo
enddo
endif
@@ -350,11 +358,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(076))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = RHSFC(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = RHSFC(ii,jj)
enddo
enddo
endif
@@ -370,11 +379,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(762))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = QVG(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = QVG(ii,jj)
enddo
enddo
endif
@@ -386,11 +396,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(760))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = QV2M(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = QV2M(ii,jj)
enddo
enddo
endif
@@ -401,11 +412,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(761))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = TSNOW(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = TSNOW(ii,jj)
enddo
enddo
endif
@@ -416,11 +428,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(724))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = SNFDEN(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = SNFDEN(ii,jj)
enddo
enddo
endif
@@ -454,11 +467,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(725))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = SNDEPAC(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = SNDEPAC(ii,jj)
enddo
enddo
endif
@@ -480,11 +494,12 @@ SUBROUTINE SURFCE
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(116))
fld_info(cfld)%lvl=LVLSXML(L,IGET(116))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = STC(i,jj,l)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = STC(ii,jj,l)
enddo
enddo
endif
@@ -500,11 +515,12 @@ SUBROUTINE SURFCE
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(116))
fld_info(cfld)%lvl=LVLSXML(L,IGET(116))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = STC(i,jj,l)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = STC(ii,jj,l)
enddo
enddo
endif
@@ -521,11 +537,12 @@ SUBROUTINE SURFCE
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(117))
fld_info(cfld)%lvl=LVLSXML(L,IGET(117))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = SMC(i,jj,l)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = SMC(ii,jj,l)
enddo
enddo
endif
@@ -539,11 +556,12 @@ SUBROUTINE SURFCE
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(117))
fld_info(cfld)%lvl=LVLSXML(L,IGET(117))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = SMC(i,jj,l)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = SMC(ii,jj,l)
enddo
enddo
endif
@@ -558,11 +576,12 @@ SUBROUTINE SURFCE
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(225))
fld_info(cfld)%lvl=LVLSXML(L,IGET(225))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = SH2O(i,jj,l)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = SH2O(ii,jj,l)
enddo
enddo
endif
@@ -576,11 +595,12 @@ SUBROUTINE SURFCE
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(225))
fld_info(cfld)%lvl=LVLSXML(L,IGET(225))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = SH2O(i,jj,l)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = SH2O(ii,jj,l)
enddo
enddo
endif
@@ -596,11 +616,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(115))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = TG(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = TG(ii,jj)
enddo
enddo
endif
@@ -608,11 +629,12 @@ SUBROUTINE SURFCE
if(iget(571)>0.and.grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(571))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = TG(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = TG(ii,jj)
enddo
enddo
endif
@@ -622,7 +644,7 @@ SUBROUTINE SURFCE
IF (IGET(171)>0) THEN
!!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(SMSTAV(I,J) /= SPVAL)THEN
GRID1(I,J) = SMSTAV(I,J)*100.
ELSE
@@ -633,11 +655,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(171))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -647,7 +670,7 @@ SUBROUTINE SURFCE
IF (IGET(036)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(SMSTOT(I,J)/=SPVAL) THEN
IF(SM(I,J) > SMALL .AND. SICE(I,J) < SMALL) THEN
GRID1(I,J) = 1000.0 ! TEMPORY FIX TO MAKE SURE SMSTOT=1 FOR WATER
@@ -662,11 +685,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(036))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -677,7 +701,7 @@ SUBROUTINE SURFCE
IF(MODELNAME == 'RAPR') THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(CMC(I,J) /= SPVAL) then
GRID1(I,J) = CMC(I,J)
else
@@ -688,7 +712,7 @@ SUBROUTINE SURFCE
else
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(CMC(I,J) /= SPVAL) then
GRID1(I,J) = CMC(I,J)*1000.
else
@@ -700,11 +724,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(118))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -716,11 +741,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(119))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = SNO(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = SNO(ii,jj)
enddo
enddo
endiF
@@ -731,7 +757,7 @@ SUBROUTINE SURFCE
! GRID1=SPVAL
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
! GRID1(I,J) = 100.*SNOAVG(I,J)
GRID1(I,J) = SNOAVG(I,J)
if (SNOAVG(I,J) /= spval) GRID1(I,J) = 100.*SNOAVG(I,J)
@@ -767,11 +793,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%tinvstat=IFHR-ID(18)
! fld_info(cfld)%ntrange=IFHR-ID(18)
! fld_info(cfld)%tinvstat=1
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -797,11 +824,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = PSFCAVG(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = PSFCAVG(ii,jj)
enddo
enddo
endif
@@ -830,11 +858,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = T10AVG(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = T10AVG(ii,jj)
enddo
enddo
endif
@@ -844,7 +873,7 @@ SUBROUTINE SURFCE
IF ( IGET(244)>0 ) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = SNONC(I,J)
ENDDO
ENDDO
@@ -873,7 +902,7 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(244))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -881,7 +910,7 @@ SUBROUTINE SURFCE
IF ( IGET(120)>0 ) THEN
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
! GRID1(I,J)=PCTSNO(I,J)
IF ( SNO(I,J) /= SPVAL ) THEN
SNEQV = SNO(I,J)
@@ -896,23 +925,24 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(120))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
ENDIF
! ADD SNOW DEPTH
IF ( IGET(224)>0 ) THEN
- ii = im/2
+ ii = (ista+iend)/2
jj = (jsta+jend)/2
! GRID1=SPVAL
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = SPVAL
IF(SI(I,J) /= SPVAL) GRID1(I,J) = SI(I,J)*0.001 ! SI comes out of WRF in mm
ENDDO
@@ -921,11 +951,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(224))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -935,11 +966,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(242))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = POTEVP(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = POTEVP(ii,jj)
enddo
enddo
endif
@@ -949,11 +981,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(349))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = DZICE(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = DZICE(ii,jj)
enddo
enddo
endif
@@ -975,10 +1008,10 @@ SUBROUTINE SURFCE
.OR.IGET(230)>0 .OR. IGET(231)>0 &
.OR.IGET(232)>0 .OR. IGET(233)>0) THEN
- allocate(smcdry(im,jsta:jend), &
- smcmax(im,jsta:jend))
+ allocate(smcdry(ista:iend,jsta:jend), &
+ smcmax(ista:iend,jsta:jend))
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
! ----------------------------------------------------------------------
! IF(QWBS(I,J)>0.001)print*,'NONZERO QWBS',i,j,QWBS(I,J)
! IF(abs(SM(I,J)-0.)<1.0E-5)THEN
@@ -1004,11 +1037,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(228))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = ECAN(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = ECAN(ii,jj)
enddo
enddo
endiF
@@ -1018,11 +1052,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(229))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = EDIR(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = EDIR(ii,jj)
enddo
enddo
endif
@@ -1032,7 +1067,7 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(230))
- datapd(1:im,1:jend-jsta+1,cfld) = ETRANS(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = ETRANS(ista:iend,jsta:jend)
endif
ENDIF
@@ -1040,7 +1075,7 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(231))
- datapd(1:im,1:jend-jsta+1,cfld) = ESNOW(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = ESNOW(ista:iend,jsta:jend)
endif
ENDIF
@@ -1048,11 +1083,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(232))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = SMCDRY(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = SMCDRY(ii,jj)
enddo
enddo
endif
@@ -1062,11 +1098,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(233))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = SMCMAX(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = SMCMAX(ii,jj)
enddo
enddo
endif
@@ -1086,11 +1123,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(512))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = acond(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = acond(ii,jj)
enddo
enddo
endiF
@@ -1124,11 +1162,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = avgECAN(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = avgECAN(ii,jj)
enddo
enddo
endiF
@@ -1162,11 +1201,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = avgEDIR(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = avgEDIR(ii,jj)
enddo
enddo
endif
@@ -1200,7 +1240,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld) = avgETRANS(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = avgETRANS(ista:iend,jsta:jend)
endif
ENDIF
@@ -1232,7 +1272,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld) = avgESNOW(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = avgESNOW(ista:iend,jsta:jend)
endif
ENDIF
@@ -1240,11 +1280,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(996))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = LANDFRAC(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = LANDFRAC(ii,jj)
enddo
enddo
endif
@@ -1254,11 +1295,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(997))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = PAHI(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = PAHI(ii,jj)
enddo
enddo
endif
@@ -1268,11 +1310,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(998))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = TWA(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = TWA(ii,jj)
enddo
enddo
endif
@@ -1281,7 +1324,7 @@ SUBROUTINE SURFCE
IF ( IGET(999)>0 )THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = TECAN(I,J)
ENDDO
ENDDO
@@ -1309,11 +1352,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(999))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1322,7 +1366,7 @@ SUBROUTINE SURFCE
IF ( IGET(1000)>0 )THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = TETRAN(I,J)
ENDDO
ENDDO
@@ -1350,11 +1394,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(1000))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1363,7 +1408,7 @@ SUBROUTINE SURFCE
IF ( IGET(1001)>0 )THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = TEDIR(I,J)
ENDDO
ENDDO
@@ -1391,11 +1436,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(1001))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1409,7 +1455,7 @@ SUBROUTINE SURFCE
RRNUM=0.
ENDIF
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(PAHA(I,J)/=SPVAL)THEN
GRID1(I,J)=-1.*PAHA(I,J)*RRNUM !change the sign to conform with Grib
ELSE
@@ -1444,7 +1490,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -1461,12 +1507,12 @@ SUBROUTINE SURFCE
(IGET(548)>0).OR.(IGET(739)>0).OR. &
(IGET(771)>0)) THEN
- if (.not. allocated(psfc)) allocate(psfc(im,jsta:jend))
+ if (.not. allocated(psfc)) allocate(psfc(ista:iend,jsta:jend))
!
!HC COMPUTE SHELTER PRESSURE BECAUSE IT WAS NOT OUTPUT FROM WRF
IF(MODELNAME == 'NCAR' .OR. MODELNAME=='RSM'.OR. MODELNAME=='RAPR')THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
TLOW = T(I,J,NINT(LMH(I,J)))
PSFC(I,J) = PINT(I,J,NINT(LMH(I,J))+1) !May not have been set above
PSHLTR(I,J) = PSFC(I,J)*EXP(-0.068283/TLOW)
@@ -1483,7 +1529,7 @@ SUBROUTINE SURFCE
IF (IGET(106)>0) THEN
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
! GRID1(I,J)=TSHLTR(I,J)
!HC CONVERT FROM THETA TO T
if(tshltr(i,j)/=spval)GRID1(I,J)=TSHLTR(I,J)*(PSHLTR(I,J)*1.E-5)**CAPA
@@ -1492,12 +1538,12 @@ SUBROUTINE SURFCE
! TSHLTR(I,J)=GRID1(I,J)
ENDDO
ENDDO
-! print *,'2m tmp=',maxval(TSHLTR(1:im,jsta:jend)), &
-! minval(TSHLTR(1:im,jsta:jend)),TSHLTR(1:3,jsta),'grd=',grid1(1:3,jsta)
+! print *,'2m tmp=',maxval(TSHLTR(ista:iend,jsta:jend)), &
+! minval(TSHLTR(ista:iend,jsta:jend)),TSHLTR(1:3,jsta),'grd=',grid1(1:3,jsta)
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(106))
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -1505,21 +1551,21 @@ SUBROUTINE SURFCE
IF (IGET(546)>0) THEN
! GRID1=spval
! DO J=JSTA,JEND
-! DO I=1,IM
+! DO I=ISTA,IEND
! GRID1(I,J)=TSHLTR(I,J)
! ENDDO
! ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(546))
- datapd(1:im,1:jend-jsta+1,cfld) = TSHLTR(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = TSHLTR(ista:iend,jsta:jend)
endif
ENDIF
!
! SHELTER LEVEL SPECIFIC HUMIDITY.
IF (IGET(112)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = QSHLTR(I,J)
ENDDO
ENDDO
@@ -1527,30 +1573,30 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(112))
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
ENDIF
! GRID1
! SHELTER MIXING RATIO.
IF (IGET(414)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = MRSHLTR(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(414))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
! SHELTER LEVEL DEWPOINT, DEWPOINT DEPRESSION AND SFC EQUIV POT TEMP.
- allocate(p1d(im,jsta:jend), t1d(im,jsta:jend))
+ allocate(p1d(ista:iend,jsta:jend), t1d(ista:iend,jsta:jend))
IF ((IGET(113)>0) .OR.(IGET(547)>0).OR.(IGET(548)>0)) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
!tgs The next 4 lines are GSD algorithm for Dew Point computation
!tgs Results are very close to dew point computed in DEWPOINT subroutine
@@ -1572,14 +1618,14 @@ SUBROUTINE SURFCE
ENDIF
ENDDO
ENDDO
- CALL DEWPOINT(EVP,EGRID1(1,jsta))
+ CALL DEWPOINT(EVP,EGRID1(ista:iend,jsta:jend))
! print *,' MAX DEWPOINT',maxval(egrid1)
! DEWPOINT
IF (IGET(113)>0) THEN
GRID1=spval
if(MODELNAME=='RAPR')THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
! DEWPOINT can't be higher than T2
t2=TSHLTR(I,J)*(PSHLTR(I,J)*1.E-5)**CAPA
if(qshltr(i,j)/=spval)GRID1(I,J)=min(EGRID1(I,J),T2)
@@ -1587,7 +1633,7 @@ SUBROUTINE SURFCE
ENDDO
else
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(qshltr(i,j)/=spval) GRID1(I,J) = EGRID1(I,J)
ENDDO
ENDDO
@@ -1595,7 +1641,7 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(113))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
@@ -1604,16 +1650,16 @@ SUBROUTINE SURFCE
! DEWPOINT at level 1 ------ p1d and t1d are undefined !! -- Moorthi
IF (IGET(771)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
EVP(I,J)=P1D(I,J)*QVl1(I,J)/(EPS+ONEPS*QVl1(I,J))
EVP(I,J)=EVP(I,J)*D001
ENDDO
ENDDO
- CALL DEWPOINT(EVP,EGRID1(1,jsta))
+ CALL DEWPOINT(EVP,EGRID1(ista:iend,jsta:jend))
! print *,' MAX DEWPOINT at level 1',maxval(egrid1)
GRID1=spval
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
!tgs 30 dec 2013 - 1st leel dewpoint can't be higher than 1-st level temperature
if(qvl1(i,j)/=spval)GRID1(I,J) = min(EGRID1(I,J),T1D(I,J))
ENDDO
@@ -1621,7 +1667,7 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(771))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!-------------------------------------------------------------------------
@@ -1631,7 +1677,7 @@ SUBROUTINE SURFCE
GRID1=SPVAL
GRID2=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(TSHLTR(I,J)/=spval.and.PSHLTR(I,J)/=spval.and.QSHLTR(I,J)/=spval) then
! DEWPOINT DEPRESSION in GRID1
GRID1(i,j)=max(0.,TSHLTR(I,J)*(PSHLTR(I,J)*1.E-5)**CAPA-EGRID1(i,j))
@@ -1651,7 +1697,7 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(547))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
@@ -1659,7 +1705,7 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(548))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID2(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID2(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -1669,10 +1715,10 @@ SUBROUTINE SURFCE
!
! SHELTER LEVEL RELATIVE HUMIDITY AND APPARENT TEMPERATURE
IF (IGET(114) > 0 .OR. IGET(808) > 0) THEN
- allocate(q1d(im,jsta:jend))
+ allocate(q1d(ista:iend,jsta:jend))
!$omp parallel do private(i,j,llmh)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(MODELNAME=='RAPR')THEN
LLMH = NINT(LMH(I,J))
! P1D(I,J)=PINT(I,J,LLMH+1)
@@ -1686,12 +1732,12 @@ SUBROUTINE SURFCE
ENDDO
ENDDO
- CALL CALRH(P1D,T1D,Q1D,EGRID1(1,jsta))
+ CALL CALRH(P1D,T1D,Q1D,EGRID1(ista:iend,jsta:jend))
if (allocated(q1d)) deallocate(q1d)
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(qshltr(i,j) /= spval)then
GRID1(I,J) = EGRID1(I,J)*100.
else
@@ -1704,11 +1750,12 @@ SUBROUTINE SURFCE
if(grib == 'grib2') then
cfld = cfld+1
fld_info(cfld)%ifld = IAVBLFLD(IGET(114))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1718,7 +1765,7 @@ SUBROUTINE SURFCE
GRID2=SPVAL
!$omp parallel do private(i,j,dum1,dum2,dum3,dum216,dum1s,dum3s)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(T1D(I,J)/=spval.and.U10H(I,J)/=spval.and.V10H(I,J)0) THEN
! DO J=JSTA,JEND
-! DO I=1,IM
+! DO I=ISTA,IEND
! GRID1(I,J)=PSHLTR(I,J)
! ENDDO
! ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(138))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = PSHLTR(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = PSHLTR(ii,jj)
enddo
enddo
endif
@@ -1795,7 +1844,7 @@ SUBROUTINE SURFCE
! SHELTER LEVEL MAX TEMPERATURE.
IF (IGET(345)>0) THEN
! DO J=JSTA,JEND
-! DO I=1,IM
+! DO I=ISTA,IEND
! GRID1(I,J)=MAXTSHLTR(I,J)
! ENDDO
! ENDDO
@@ -1829,11 +1878,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
if(IFHR==0) fld_info(cfld)%tinvstat=0
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = MAXTSHLTR(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = MAXTSHLTR(ii,jj)
enddo
enddo
endif
@@ -1843,7 +1893,7 @@ SUBROUTINE SURFCE
IF (IGET(346)>0) THEN
!!$omp parallel do private(i,j)
! DO J=JSTA,JEND
-! DO I=1,IM
+! DO I=ISTA,IEND
! GRID1(I,J) = MINTSHLTR(I,J)
! ENDDO
! ENDDO
@@ -1875,11 +1925,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
if(IFHR==0) fld_info(cfld)%tinvstat=0
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = MINTSHLTR(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = MINTSHLTR(ii,jj)
enddo
enddo
endif
@@ -1889,7 +1940,7 @@ SUBROUTINE SURFCE
IF (IGET(347)>0) THEN
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(MAXRHSHLTR(I,J)/=spval) GRID1(I,J)=MAXRHSHLTR(I,J)*100.
ENDDO
ENDDO
@@ -1927,11 +1978,12 @@ SUBROUTINE SURFCE
if(IFHR==0) fld_info(cfld)%tinvstat=0
! print*,'id(18),tinvstat,IFHR,ITMAXMIN in rhmax= ',ID(18),fld_info(cfld)%tinvstat, &
! IFHR, ITMAXMIN
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -1941,7 +1993,7 @@ SUBROUTINE SURFCE
IF (IGET(348)>0) THEN
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(MINRHSHLTR(I,J)/=spval) GRID1(I,J)=MINRHSHLTR(I,J)*100.
ENDDO
ENDDO
@@ -1977,11 +2029,12 @@ SUBROUTINE SURFCE
! fld_info(cfld)%tinvstat=ITMAXMIN
fld_info(cfld)%tinvstat=IFHR-ID(18)
if(IFHR==0) fld_info(cfld)%tinvstat=0
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2017,11 +2070,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=1
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = maxqshltr(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = maxqshltr(ii,jj)
enddo
enddo
endif
@@ -2056,11 +2110,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=1
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = minqshltr(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = minqshltr(ii,jj)
enddo
enddo
endif
@@ -2071,7 +2126,7 @@ SUBROUTINE SURFCE
IF (IGET(739)>0) THEN
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(T(I,J,LM)/=spval.and.PMID(I,J,LM)/=spval.and.SMOKE(I,J,LM,1)/=spval)&
GRID1(I,J) = (1./RD)*(PMID(I,J,LM)/T(I,J,LM))*SMOKE(I,J,LM,1)
ENDDO
@@ -2079,7 +2134,7 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(739))
- datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -2092,7 +2147,7 @@ SUBROUTINE SURFCE
IF ((IGET(064)>0).OR.(IGET(065)>0)) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = U10(I,J)
GRID2(I,J) = V10(I,J)
ENDDO
@@ -2100,20 +2155,22 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(064))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(065))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -2122,7 +2179,7 @@ SUBROUTINE SURFCE
IF (IGET(730)>0) THEN
IFINCR = 5
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=SPDUV10MEAN(I,J)
ENDDO
ENDDO
@@ -2138,7 +2195,7 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!---
@@ -2146,7 +2203,7 @@ SUBROUTINE SURFCE
IF (IGET(731)>0) THEN
IFINCR = 5
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=U10MEAN(I,J)
ENDDO
ENDDO
@@ -2161,14 +2218,14 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
! GSD - Time-averaged V wind speed (forecast time labels will all be in minutes)
IF (IGET(732)>0) THEN
IFINCR = 5
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=V10MEAN(I,J)
ENDDO
ENDDO
@@ -2183,14 +2240,14 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
! Time-averaged SWDOWN (forecast time labels will all be in minutes)
IF (IGET(733)>0 )THEN
IFINCR = 15
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = SWRADMEAN(I,J)
ENDDO
ENDDO
@@ -2205,14 +2262,14 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
! Time-averaged SWNORM (forecast time labels will all be in minutes)
IF (IGET(734)>0 )THEN
IFINCR = 15
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = SWNORMMEAN(I,J)
ENDDO
ENDDO
@@ -2227,7 +2284,7 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
endif
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -2242,7 +2299,7 @@ SUBROUTINE SURFCE
ENDIF
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = U10MAX(I,J)
GRID2(I,J) = V10MAX(I,J)
ENDDO
@@ -2256,11 +2313,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
cfld=cfld+1
@@ -2271,11 +2329,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -2288,18 +2347,19 @@ SUBROUTINE SURFCE
IF (IGET(158)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=TH10(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(158))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2310,18 +2370,19 @@ SUBROUTINE SURFCE
IF (IGET(505)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=T10M(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(505))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2332,18 +2393,19 @@ SUBROUTINE SURFCE
IF (IGET(159)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = Q10(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(159))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2356,7 +2418,7 @@ SUBROUTINE SURFCE
IF (IGET(422)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = WSPD10MAX(I,J)
ENDDO
ENDDO
@@ -2369,11 +2431,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%tinvstat=1
endif
fld_info(cfld)%ntrange=1
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2384,7 +2447,7 @@ SUBROUTINE SURFCE
IF (IGET(783)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = WSPD10UMAX(I,J)
ENDDO
ENDDO
@@ -2397,11 +2460,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%tinvstat=1
endif
fld_info(cfld)%ntrange=1
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2412,7 +2476,7 @@ SUBROUTINE SURFCE
IF (IGET(784)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = WSPD10VMAX(I,J)
ENDDO
ENDDO
@@ -2425,10 +2489,11 @@ SUBROUTINE SURFCE
fld_info(cfld)%tinvstat=1
endif
fld_info(cfld)%ntrange=1
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
+ do i=1,iend-ista+1
+ ii = ista+i-1
datapd(i,j,cfld) = GRID1(i,jj)
enddo
enddo
@@ -2443,10 +2508,10 @@ SUBROUTINE SURFCE
!
IF (IGET(588)>0) THEN
- CALL CALVESSEL(ICEG(1,jsta))
+ CALL CALVESSEL(ICEG(ista:iend,jsta:jend))
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = ICEG(I,J)
ENDDO
ENDDO
@@ -2461,11 +2526,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2491,7 +2557,7 @@ SUBROUTINE SURFCE
IF (IGET(172)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (PREC(I,J) <= PTHRESH .OR. SR(I,J)==spval) THEN
GRID1(I,J) = -50.
ELSE
@@ -2502,11 +2568,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(172))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2520,7 +2587,7 @@ SUBROUTINE SURFCE
GRID1=SPVAL
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(CPRATE(I,J)/=spval) GRID1(I,J) = CPRATE(I,J)*RDTPHS
! GRID1(I,J) = CUPPT(I,J)*RDTPHS
ENDDO
@@ -2528,11 +2595,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(249))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2546,7 +2614,7 @@ SUBROUTINE SURFCE
GRID1=SPVAL
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(PREC(I,J)/=spval) then
IF(MODELNAME /= 'RSM') THEN
GRID1(I,J) = PREC(I,J)*RDTPHS*1000.
@@ -2559,11 +2627,18 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(167))
-!$omp parallel do private(i,j,jj)
+ if(ITSRFC>0) then
+ fld_info(cfld)%ntrange=1
+ else
+ fld_info(cfld)%ntrange=0
+ endif
+ fld_info(cfld)%tinvstat=IFHR-ID(18)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2574,7 +2649,7 @@ SUBROUTINE SURFCE
!-- PRATE_MAX in units of mm/h from NMMB history files
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(PRATE_MAX(I,J)/=spval) GRID1(I,J)=PRATE_MAX(I,J)*SEC2HR
ENDDO
ENDDO
@@ -2588,11 +2663,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2603,7 +2679,7 @@ SUBROUTINE SURFCE
!-- FPRATE_MAX in units of mm/h from NMMB history files
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(FPRATE_MAX(I,J)/=spval) GRID1(I,J)=FPRATE_MAX(I,J)*SEC2HR
ENDDO
ENDDO
@@ -2617,11 +2693,12 @@ SUBROUTINE SURFCE
else
fld_info(cfld)%ntrange=0
endif
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2654,7 +2731,7 @@ SUBROUTINE SURFCE
grid1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(AVGCPRATE(I,J)/=spval) GRID1(I,J) = AVGCPRATE(I,J)*RDTPHS
ENDDO
ENDDO
@@ -2673,11 +2750,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2711,7 +2789,7 @@ SUBROUTINE SURFCE
grid1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(avgprec(i,j)/=spval) GRID1(I,J) = AVGPREC(I,J)*RDTPHS
ENDDO
ENDDO
@@ -2727,11 +2805,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -2762,7 +2841,7 @@ SUBROUTINE SURFCE
IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(AVGPREC(I,J) < SPVAL)THEN
GRID1(I,J) = AVGPREC(I,J)*FLOAT(ID(19)-ID(18))*3600.*1000./DTQ2
ELSE
@@ -2772,7 +2851,7 @@ SUBROUTINE SURFCE
ENDDO
!! Chuang 3/29/2018: add continuous bucket
! DO J=JSTA,JEND
-! DO I=1,IM
+! DO I=ISTA,IEND
! IF(AVGPREC_CONT(I,J) < SPVAL)THEN
! GRID2(I,J) = AVGPREC_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2
! ELSE
@@ -2783,7 +2862,7 @@ SUBROUTINE SURFCE
ELSE
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(ACPREC(I,J) < SPVAL)THEN
GRID1(I,J) = ACPREC(I,J)*1000.
ELSE
@@ -2805,11 +2884,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
! print*,'id(18),tinvstat in apcp= ',ID(18),fld_info(cfld)%tinvstat
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
!! add continuous bucket
@@ -2856,7 +2936,7 @@ SUBROUTINE SURFCE
! Chuang 3/29/2018: add continuous bucket
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(AVGPREC_CONT(I,J) < SPVAL)THEN
GRID2(I,J) = AVGPREC_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2
ELSE
@@ -2874,11 +2954,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR
! print*,'tinvstat in cont bucket= ',fld_info(cfld)%tinvstat
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -2911,7 +2992,7 @@ SUBROUTINE SURFCE
IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(AVGCPRATE(I,J) < SPVAL)THEN
GRID1(I,J) = AVGCPRATE(I,J)* &
FLOAT(ID(19)-ID(18))*3600.*1000./DTQ2
@@ -2922,7 +3003,7 @@ SUBROUTINE SURFCE
ENDDO
!! Chuang 3/29/2018: add continuous bucket
! DO J=JSTA,JEND
-! DO I=1,IM
+! DO I=ISTA,IEND
! IF(AVGCPRATE_CONT(I,J) < SPVAL)THEN
! GRID2(I,J) = AVGCPRATE_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2
! ELSE
@@ -2933,7 +3014,7 @@ SUBROUTINE SURFCE
ELSE
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(CUPREC(I,J) < SPVAL)THEN
GRID1(I,J) = CUPREC(I,J)*1000.
ELSE
@@ -2948,11 +3029,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(033))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
!! add continuous bucket
@@ -2998,7 +3080,7 @@ SUBROUTINE SURFCE
! Chuang 3/29/2018: add continuous bucket
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(AVGCPRATE_CONT(I,J) < SPVAL)THEN
GRID2(I,J) = AVGCPRATE_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2
ELSE
@@ -3015,11 +3097,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(418))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -3053,7 +3136,7 @@ SUBROUTINE SURFCE
IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(AVGCPRATE(I,J) < SPVAL .AND. AVGPREC(I,J) < SPVAL) then
GRID1(I,J) = ( AVGPREC(I,J) - AVGCPRATE(I,J) ) * &
FLOAT(ID(19)-ID(18))*3600.*1000./DTQ2
@@ -3064,7 +3147,7 @@ SUBROUTINE SURFCE
ENDDO
!! Chuang 3/29/2018: add continuous bucket
! DO J=JSTA,JEND
-! DO I=1,IM
+! DO I=ISTA,IEND
! IF(AVGCPRATE_CONT(I,J) < SPVAL .AND. AVGPREC_CONT(I,J) < SPVAL)THEN
! GRID2(I,J) = (AVGPREC_CONT(I,J) - AVGCPRATE_CONT(I,J)) &
! *FLOAT(IFHR)*3600.*1000./DTQ2
@@ -3076,7 +3159,7 @@ SUBROUTINE SURFCE
ELSE
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = ANCPRC(I,J)*1000.
ENDDO
ENDDO
@@ -3087,11 +3170,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(034))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
!! add continuous bucket
@@ -3102,8 +3186,9 @@ SUBROUTINE SURFCE
! fld_info(cfld)%tinvstat=IFHR
! do j=1,jend-jsta+1
! jj = jsta+j-1
-! do i=1,im
-! datapd(i,j,cfld) = GRID2(i,jj)
+! do i=1,iend-ista+1
+! ii = ista+1-1
+! datapd(i,j,cfld) = GRID2(ii,jj)
! enddo
! enddo
! endif
@@ -3137,7 +3222,7 @@ SUBROUTINE SURFCE
! Chuang 3/29/2018: add continuous bucket
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(AVGCPRATE_CONT(I,J) < SPVAL .AND. AVGPREC_CONT(I,J) < SPVAL)THEN
GRID2(I,J) = (AVGPREC_CONT(I,J) - AVGCPRATE_CONT(I,J)) &
*FLOAT(IFHR)*3600.*1000./DTQ2
@@ -3155,11 +3240,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(419))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID2(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID2(ii,jj)
enddo
enddo
endif
@@ -3171,7 +3257,7 @@ SUBROUTINE SURFCE
GRID1=SPVAL
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(LSPA(I,J)<=-1.0E-6)THEN
if(ACPREC(I,J)/=spval) GRID1(I,J) = ACPREC(I,J)*1000
ELSE
@@ -3206,11 +3292,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(256))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3220,7 +3307,7 @@ SUBROUTINE SURFCE
IF (IGET(035)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
! GRID1(I,J) = ACSNOW(I,J)*1000.
GRID1(I,J) = ACSNOW(I,J)
ENDDO
@@ -3251,11 +3338,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(035))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3265,7 +3353,7 @@ SUBROUTINE SURFCE
IF (IGET(746)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = ACGRAUP(I,J)
ENDDO
ENDDO
@@ -3295,11 +3383,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(746))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3309,7 +3398,7 @@ SUBROUTINE SURFCE
IF (IGET(782)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = ACFRAIN(I,J)
ENDDO
ENDDO
@@ -3339,11 +3428,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(782))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3353,7 +3443,7 @@ SUBROUTINE SURFCE
IF (IGET(121)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
! GRID1(I,J) = ACSNOM(I,J)*1000.
GRID1(I,J) = ACSNOM(I,J)
ENDDO
@@ -3384,11 +3474,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(121))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3398,7 +3489,7 @@ SUBROUTINE SURFCE
IF (IGET(405)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = SNOWFALL(I,J)
ENDDO
ENDDO
@@ -3429,11 +3520,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(405))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3443,7 +3535,7 @@ SUBROUTINE SURFCE
IF (IGET(122)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
! GRID1(I,J) = SSROFF(I,J)*1000.
GRID1(I,J) = SSROFF(I,J)
ENDDO
@@ -3482,11 +3574,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(122))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3496,7 +3589,7 @@ SUBROUTINE SURFCE
IF (IGET(123)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
! GRID1(I,J) = BGROFF(I,J)*1000.
GRID1(I,J) = BGROFF(I,J)
ENDDO
@@ -3535,11 +3628,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(123))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3549,7 +3643,7 @@ SUBROUTINE SURFCE
IF (IGET(343)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RUNOFF(I,J)
ENDDO
ENDDO
@@ -3582,11 +3676,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(343))
fld_info(cfld)%ntrange=1
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3597,7 +3692,7 @@ SUBROUTINE SURFCE
IF (IGET(434)>0.) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (IFHR == 0) THEN
GRID1(I,J) = 0.0
ELSE
@@ -3644,11 +3739,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3659,7 +3755,7 @@ SUBROUTINE SURFCE
IF (IGET(435)>0.) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (IFHR == 0) THEN
GRID1(I,J) = 0.0
ELSE
@@ -3713,11 +3809,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3727,7 +3824,7 @@ SUBROUTINE SURFCE
IF (IGET(436)>0.) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (IFHR == 0) THEN
GRID1(I,J) = 0.0
ELSE
@@ -3774,11 +3871,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3788,7 +3886,7 @@ SUBROUTINE SURFCE
IF (IGET(437)>0.) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = SNOW_BUCKET(I,J)
ENDDO
ENDDO
@@ -3832,11 +3930,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -3846,7 +3945,7 @@ SUBROUTINE SURFCE
IF (IGET(775)>0.) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = GRAUP_BUCKET(I,J)
ENDDO
ENDDO
@@ -3890,11 +3989,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4038,7 +4138,7 @@ SUBROUTINE SURFCE
IF (IGET(526)>0.) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (IFHR == 0 .AND. IFMIN == 0) THEN
GRID1(I,J) = 0.0
ELSE
@@ -4058,11 +4158,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4071,7 +4172,7 @@ SUBROUTINE SURFCE
IF (IGET(527)>0.) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (IFHR == 0 .AND. IFMIN == 0) THEN
GRID1(I,J) = 0.0
ELSE
@@ -4091,11 +4192,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4104,7 +4206,7 @@ SUBROUTINE SURFCE
IF (IGET(528)>0.) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (IFHR == 0 .AND. IFMIN == 0) THEN
GRID1(I,J) = 0.0
ELSE
@@ -4124,11 +4226,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4137,7 +4240,7 @@ SUBROUTINE SURFCE
IF (IGET(529)>0.) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (IFHR == 0 .AND. IFMIN == 0) THEN
GRID1(I,J) = 0.0
ELSE
@@ -4158,11 +4261,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4171,7 +4275,7 @@ SUBROUTINE SURFCE
IF (IGET(530)>0.) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (IFHR == 0 .AND. IFMIN == 0) THEN
GRID1(I,J) = 0.0
ELSE
@@ -4192,11 +4296,12 @@ SUBROUTINE SURFCE
endif
fld_info(cfld)%ntrange=1
end if
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4206,9 +4311,9 @@ SUBROUTINE SURFCE
! print *,'in surfce,iget(160)=',iget(160),'iget(247)=',iget(247)
IF (IGET(160)>0 .OR.(IGET(247)>0)) THEN
- allocate(sleet(im,jsta:jend,nalg), rain(im,jsta:jend,nalg), &
- freezr(im,jsta:jend,nalg), snow(im,jsta:jend,nalg))
- allocate(zwet(im,jsta:jend))
+ allocate(sleet(ista:iend,jsta:jend,nalg), rain(ista:iend,jsta:jend,nalg), &
+ freezr(ista:iend,jsta:jend,nalg), snow(ista:iend,jsta:jend,nalg))
+ allocate(zwet(ista:iend,jsta:jend))
CALL CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX1,ZWET)
! write(0,*)' after first CALWXT_POST'
@@ -4216,7 +4321,7 @@ SUBROUTINE SURFCE
IF (IGET(160)>0) THEN
!$omp parallel do private(i,j,iwx)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(ZWET(I,J)0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = ZWET(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(247))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4267,7 +4373,7 @@ SUBROUTINE SURFCE
!
!$omp parallel do private(i,j,iwx)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IWX = IWX1(I,J)
SNOW(I,J,2) = MOD(IWX,2)
SLEET(I,J,2) = MOD(IWX,4)/2
@@ -4280,7 +4386,7 @@ SUBROUTINE SURFCE
ISEED=44641*(INT(SDAT(1)-1)*24*31+INT(SDAT(2))*24+IHRST)+ &
& MOD(IFHR*60+IFMIN,44641)+4357
! write(0,*)'in SURFCE,me=',me,'bef 1st CALWXT_BOURG_POST iseed=',iseed
- CALL CALWXT_BOURG_POST(IM,JM,JSTA_2L,JEND_2U,JSTA,JEND,LM,LP1,&
+ CALL CALWXT_BOURG_POST(IM,ISTA_2L,IEND_2U,ISTA,IEND,JM,JSTA_2L,JEND_2U,JSTA,JEND,LM,LP1,&
& ISEED,G,PTHRESH, &
& T,Q,PMID,PINT,LMH,PREC,ZINT,IWX1,me)
! write(0,*)'in SURFCE,me=',me,'aft 1st CALWXT_BOURG_POST'
@@ -4290,7 +4396,7 @@ SUBROUTINE SURFCE
!
!$omp parallel do private(i,j,iwx)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IWX = IWX1(I,J)
SNOW(I,J,3) = MOD(IWX,2)
SLEET(I,J,3) = MOD(IWX,4)/2
@@ -4306,7 +4412,7 @@ SUBROUTINE SURFCE
!
!$omp parallel do private(i,j,iwx)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IWX = IWX1(I,J)
SNOW(I,J,4) = MOD(IWX,2)
SLEET(I,J,4) = MOD(IWX,4)/2
@@ -4322,7 +4428,7 @@ SUBROUTINE SURFCE
else
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IWX1(I,J) = 0
ENDDO
ENDDO
@@ -4332,7 +4438,7 @@ SUBROUTINE SURFCE
!
!$omp parallel do private(i,j,iwx)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IWX = IWX1(I,J)
SNOW(I,J,5) = MOD(IWX,2)
SLEET(I,J,5) = MOD(IWX,4)/2
@@ -4341,27 +4447,28 @@ SUBROUTINE SURFCE
ENDDO
ENDDO
- allocate(domr(im,jsta:jend), doms(im,jsta:jend), &
- domzr(im,jsta:jend), domip(im,jsta:jend))
- CALL CALWXT_DOMINANT_POST(PREC(1,jsta_2l),RAIN,FREEZR,SLEET,SNOW, &
+ allocate(domr(ista:iend,jsta:jend), doms(ista:iend,jsta:jend), &
+ domzr(ista:iend,jsta:jend), domip(ista:iend,jsta:jend))
+ CALL CALWXT_DOMINANT_POST(PREC(ista_2l,jsta_2l),RAIN,FREEZR,SLEET,SNOW, &
DOMR,DOMZR,DOMIP,DOMS)
! if ( me==0) print *,'after CALWXT_DOMINANT, no avrg'
! SNOW.
grid1 = spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(prec(i,j) /= spval) GRID1(I,J) = DOMS(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(551))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4369,18 +4476,19 @@ SUBROUTINE SURFCE
grid1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(prec(i,j)/=spval) GRID1(I,J) = DOMIP(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(552))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4388,7 +4496,7 @@ SUBROUTINE SURFCE
grid1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
! if (DOMZR(I,J) == 1) THEN
! PSFC(I,J)=PINT(I,J,NINT(LMH(I,J))+1)
! print *, 'aha ', I, J, PSFC(I,J)
@@ -4401,11 +4509,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(553))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4413,18 +4522,19 @@ SUBROUTINE SURFCE
grid1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(prec(i,j)/=spval)GRID1(I,J) = DOMR(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(160))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -4434,16 +4544,16 @@ SUBROUTINE SURFCE
! TIME AVERAGED PRECIPITATION TYPE.
IF (IGET(317)>0) THEN
- if (.not. allocated(sleet)) allocate(sleet(im,jsta:jend,nalg))
- if (.not. allocated(rain)) allocate(rain(im,jsta:jend,nalg))
- if (.not. allocated(freezr)) allocate(freezr(im,jsta:jend,nalg))
- if (.not. allocated(snow)) allocate(snow(im,jsta:jend,nalg))
- if (.not. allocated(zwet)) allocate(zwet(im,jsta:jend))
+ if (.not. allocated(sleet)) allocate(sleet(ista:iend,jsta:jend,nalg))
+ if (.not. allocated(rain)) allocate(rain(ista:iend,jsta:jend,nalg))
+ if (.not. allocated(freezr)) allocate(freezr(ista:iend,jsta:jend,nalg))
+ if (.not. allocated(snow)) allocate(snow(ista:iend,jsta:jend,nalg))
+ if (.not. allocated(zwet)) allocate(zwet(ista:iend,jsta:jend))
CALL CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,AVGPREC,ZINT,IWX1,ZWET)
!$omp parallel do private(i,j,iwx)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(ZWET(I,J)0 .or. IGET(559)>0 .or. &
IGET(560)>0 .or. IGET(561)>0) THEN
- if (.not. allocated(domr)) allocate(domr(im,jsta:jend))
- if (.not. allocated(doms)) allocate(doms(im,jsta:jend))
- if (.not. allocated(domzr)) allocate(domzr(im,jsta:jend))
- if (.not. allocated(domip)) allocate(domip(im,jsta:jend))
+ if (.not. allocated(domr)) allocate(domr(ista:iend,jsta:jend))
+ if (.not. allocated(doms)) allocate(doms(ista:iend,jsta:jend))
+ if (.not. allocated(domzr)) allocate(domzr(ista:iend,jsta:jend))
+ if (.not. allocated(domip)) allocate(domip(ista:iend,jsta:jend))
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
DOMS(I,J) = 0. !-- snow
DOMR(I,J) = 0. !-- rain
DOMZR(I,J) = 0. !-- freezing rain
@@ -4790,7 +4904,7 @@ SUBROUTINE SURFCE
ENDDO
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
!-- TOTPRCP is total 1-hour accumulated precipitation in [m]
totprcp = (RAINC_BUCKET(I,J) + RAINNC_BUCKET(I,J))*1.e-3
snowratio = 0.0
@@ -4911,7 +5025,7 @@ SUBROUTINE SURFCE
maxval(snow_bucket)*0.1,minval(snow_bucket)*0.1
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
do icat=1,10
if (snow_bucket(i,j)*0.1<0.1*float(icat).and. &
snow_bucket(i,j)*0.1>0.1*float(icat-1)) then
@@ -4928,7 +5042,7 @@ SUBROUTINE SURFCE
icnt_snow_rain_mixed = 0
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if (DOMR(i,j)==1 .and. DOMS(i,j)==1) then
icnt_snow_rain_mixed = icnt_snow_rain_mixed + 1
endif
@@ -4942,25 +5056,26 @@ SUBROUTINE SURFCE
! SNOW.
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=DOMS(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(559))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
! ICE PELLETS.
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = DOMIP(I,J)
! if (DOMIP(I,J) == 1) THEN
! print *, 'ICE PELLETS at I,J ', I, J
@@ -4970,18 +5085,19 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(560))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
! FREEZING RAIN.
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
! if (DOMZR(I,J) == 1) THEN
! PSFC(I,J)=PINT(I,J,NINT(LMH(I,J))+1)
! print *, 'FREEZING RAIN AT I,J ', I, J, PSFC(I,J)
@@ -4992,29 +5108,31 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(561))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
! RAIN.
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = DOMR(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(407))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -5043,7 +5161,7 @@ SUBROUTINE SURFCE
RRNUM=0.
ENDIF
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(SFCLHX(I,J)/=SPVAL)THEN
GRID1(I,J)=-1.*SFCLHX(I,J)*RRNUM !change the sign to conform with Grib
ELSE
@@ -5078,7 +5196,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
END IF
ENDIF
@@ -5096,7 +5214,7 @@ SUBROUTINE SURFCE
RRNUM=0.
ENDIF
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(SFCSHX(I,J)/=SPVAL)THEN
GRID1(I,J) = -1.* SFCSHX(I,J)*RRNUM !change the sign to conform with Grib
ELSE
@@ -5132,7 +5250,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -5150,7 +5268,7 @@ SUBROUTINE SURFCE
ENDIF
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(SUBSHX(I,J)/=spval) GRID1(I,J) = SUBSHX(I,J)*RRNUM
ENDDO
ENDDO
@@ -5182,7 +5300,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -5200,7 +5318,7 @@ SUBROUTINE SURFCE
ENDIF
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(SNOPCX(I,J)/=spval) GRID1(I,J) = SNOPCX(I,J)*RRNUM
ENDDO
ENDDO
@@ -5232,7 +5350,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -5249,7 +5367,7 @@ SUBROUTINE SURFCE
RRNUM=0.
ENDIF
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(SFCUVX(I,J)/=SPVAL)THEN
GRID1(I,J) = SFCUVX(I,J)*RRNUM
ELSE
@@ -5285,7 +5403,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -5303,7 +5421,7 @@ SUBROUTINE SURFCE
ENDIF
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(SFCUX(I,J)/=spval) GRID1(I,J) = SFCUX(I,J)*RRNUM
ENDDO
ENDDO
@@ -5335,7 +5453,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -5353,7 +5471,7 @@ SUBROUTINE SURFCE
ENDIF
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(SFCVX(I,J)/=spval) GRID1(I,J) = SFCVX(I,J)*RRNUM
ENDDO
ENDDO
@@ -5385,7 +5503,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -5393,7 +5511,7 @@ SUBROUTINE SURFCE
IF (IGET(047)>0) THEN
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(SFCEVP(I,J)/=spval) GRID1(I,J) = SFCEVP(I,J)*1000.
ENDDO
ENDDO
@@ -5427,7 +5545,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
@@ -5436,7 +5554,7 @@ SUBROUTINE SURFCE
IF (IGET(137)>0) THEN
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(POTEVP(I,J)/=spval) GRID1(I,J) = POTEVP(I,J)*1000.
ENDDO
ENDDO
@@ -5470,35 +5588,35 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
! ROUGHNESS LENGTH.
IF (IGET(044)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = Z0(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(044))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
! FRICTION VELOCITY.
IF (IGET(045)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = USTAR(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(045))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -5506,41 +5624,41 @@ SUBROUTINE SURFCE
! dong add missing value for cd
IF (IGET(132)>0) THEN
GRID1=spval
- CALL CALDRG(EGRID1(1,jsta_2l))
+ CALL CALDRG(EGRID1(ista_2l:iend_2u,jsta_2l:jend_2u))
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(USTAR(I,J) < spval) GRID1(I,J)=EGRID1(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(132))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
write_cd: IF(IGET(922)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=CD10(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(922))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF write_cd
write_ch: IF(IGET(923)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=CH10(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(923))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF write_ch
!
@@ -5550,14 +5668,14 @@ SUBROUTINE SURFCE
! MODEL OUTPUT SURFACE U COMPONENT WIND STRESS.
IF (IGET(900)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=MDLTAUX(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(900))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
@@ -5565,14 +5683,14 @@ SUBROUTINE SURFCE
! MODEL OUTPUT SURFACE V COMPONENT WIND STRESS
IF (IGET(901)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=MDLTAUY(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(901))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -5582,13 +5700,13 @@ SUBROUTINE SURFCE
! dong add missing value
GRID1 = spval
IF(MODELNAME /= 'FV3R') &
- CALL CALTAU(EGRID1(1,jsta),EGRID2(1,jsta))
+ CALL CALTAU(EGRID1(ista:iend,jsta:jend),EGRID2(ista:iend,jsta:jend))
!
! SURFACE U COMPONENT WIND STRESS.
! dong for FV3, directly use model output
IF (IGET(133)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(MODELNAME == 'FV3R') THEN
GRID1(I,J)=SFCUXI(I,J)
ELSE
@@ -5600,14 +5718,14 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(133))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
! SURFACE V COMPONENT WIND STRESS
IF (IGET(134)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(MODELNAME == 'FV3R') THEN
GRID1(I,J)=SFCVXI(I,J)
ELSE
@@ -5618,7 +5736,7 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(134))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -5629,7 +5747,7 @@ SUBROUTINE SURFCE
! GRAVITY U COMPONENT WIND STRESS.
IF (IGET(315)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = GTAUX(I,J)
ENDDO
ENDDO
@@ -5660,14 +5778,14 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=1
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
! SURFACE V COMPONENT WIND STRESS
IF (IGET(316)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=GTAUY(I,J)
ENDDO
ENDDO
@@ -5698,7 +5816,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=1
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -5711,14 +5829,14 @@ SUBROUTINE SURFCE
MODELNAME=='RAPR')THEN
!4omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = TWBS(I,J)
ENDDO
ENDDO
ELSE
!4omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(TWBS(I,J) < spval) GRID1(I,J) = -TWBS(I,J)
ENDDO
ENDDO
@@ -5726,7 +5844,7 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(154))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -5738,14 +5856,14 @@ SUBROUTINE SURFCE
MODELNAME=='RAPR')THEN
!4omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = QWBS(I,J)
ENDDO
ENDDO
ELSE
!4omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(QWBS(I,J) < spval) GRID1(I,J) = -QWBS(I,J)
ENDDO
ENDDO
@@ -5753,21 +5871,21 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(155))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
! SURFACE EXCHANGE COEFF
IF (IGET(169)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=SFCEXC(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(169))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -5775,14 +5893,14 @@ SUBROUTINE SURFCE
IF (IGET(170)>0) THEN
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(VEGFRC(I,J)/=spval) GRID1(I,J)=VEGFRC(I,J)*100.
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(170))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
@@ -5791,14 +5909,14 @@ SUBROUTINE SURFCE
IF (IGET(726)>0) THEN
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(shdmin(I,J)/=spval) GRID1(I,J)=shdmin(I,J)*100.
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(726))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -5806,14 +5924,14 @@ SUBROUTINE SURFCE
IF (IGET(729)>0) THEN
GRID1=SPVAL
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
if(shdmax(I,J)/=spval) GRID1(I,J)=shdmax(I,J)*100.
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(729))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
@@ -5823,7 +5941,7 @@ SUBROUTINE SURFCE
IF (iSF_SURFACE_PHYSICS == 2 .OR. MODELNAME=='RAPR') THEN
IF (IGET(254)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (MODELNAME=='RAPR')THEN
GRID1(I,J)=LAI(I,J)
ELSE
@@ -5834,7 +5952,7 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(254))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
ENDIF
@@ -5843,54 +5961,54 @@ SUBROUTINE SURFCE
! INSTANTANEOUS GROUND HEAT FLUX
IF (IGET(152)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=GRNFLX(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(152))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
! VEGETATION TYPE
IF (IGET(218)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = FLOAT(IVGTYP(I,J))
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(218))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
! SOIL TYPE
IF (IGET(219)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = FLOAT(ISLTYP(I,J))
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(219))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
! SLOPE TYPE
IF (IGET(223)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = FLOAT(ISLOPE(I,J))
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(223))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
! if (me==0)print*,'starting computing canopy conductance'
@@ -5906,10 +6024,10 @@ SUBROUTINE SURFCE
& .OR. IGET(241)>0 ) THEN
IF (iSF_SURFACE_PHYSICS == 2) THEN !NSOIL == 4
! if(me==0)print*,'starting computing canopy conductance'
- allocate(rsmin(im,jsta:jend), smcref(im,jsta:jend), gc(im,jsta:jend), &
- rcq(im,jsta:jend), rct(im,jsta:jend), rcsoil(im,jsta:jend), rcs(im,jsta:jend))
+ allocate(rsmin(ista:iend,jsta:jend), smcref(ista:iend,jsta:jend), gc(ista:iend,jsta:jend), &
+ rcq(ista:iend,jsta:jend), rct(ista:iend,jsta:jend), rcsoil(ista:iend,jsta:jend), rcs(ista:iend,jsta:jend))
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF( (abs(SM(I,J)-0.) < 1.0E-5) .AND. &
& (abs(SICE(I,J)-0.) < 1.0E-5) ) THEN
IF(CZMEAN(I,J)>1.E-6) THEN
@@ -5952,118 +6070,118 @@ SUBROUTINE SURFCE
IF (IGET(220)>0 )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = GC(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(220))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
IF (IGET(234)>0 )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RSMIN(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(234))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
IF (IGET(235)>0 )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = FLOAT(NROOTS(I,J))
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(235))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
IF (IGET(236)>0 )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = SMCWLT(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(236))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
IF (IGET(237)>0 )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = SMCREF(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(237))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
IF (IGET(238)>0 )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RCS(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(238))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
IF (IGET(239)>0 )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RCT(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(239))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
IF (IGET(240)>0 )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RCQ(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(240))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
IF (IGET(241)>0 )THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = RCSOIL(I,J)
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(241))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
@@ -6085,7 +6203,7 @@ SUBROUTINE SURFCE
IF(IGET(236)>0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = smcwlt(i,j)
! IF(isltyp(i,j)/=0)THEN
! GRID1(I,J) = WLTSMC(isltyp(i,j))
@@ -6097,11 +6215,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(236))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -6110,7 +6229,7 @@ SUBROUTINE SURFCE
IF(IGET(397)>0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = fieldcapa(i,j)
! IF(isltyp(i,j)/=0)THEN
! GRID1(I,J) = REFSMC(isltyp(i,j))
@@ -6122,11 +6241,12 @@ SUBROUTINE SURFCE
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(397))
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -6135,7 +6255,7 @@ SUBROUTINE SURFCE
IF(IGET(396)>0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = suntime(i,j)
ENDDO
ENDDO
@@ -6166,11 +6286,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -6179,7 +6300,7 @@ SUBROUTINE SURFCE
IF(IGET(517)>0)THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = avgpotevp(i,j)
ENDDO
ENDDO
@@ -6210,11 +6331,12 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = GRID1(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = GRID1(ii,jj)
enddo
enddo
endif
@@ -6226,21 +6348,21 @@ SUBROUTINE SURFCE
IF (IGET(282)>0) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J) = PT
ENDDO
ENDDO
if(grib=='grib2') then
cfld=cfld+1
fld_info(cfld)%ifld=IAVBLFLD(IGET(282))
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
! PRESSURE THICKNESS REQUESTED BY CMAQ
IF (IGET(283)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=PDTOP
ENDDO
ENDDO
@@ -6257,14 +6379,14 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(283))
fld_info(cfld)%lvl1=1
fld_info(cfld)%lvl2=L
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
!
! SIGMA PRESSURE THICKNESS REQUESTED BY CMAQ
IF (IGET(273)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=PD(I,J)
ENDDO
ENDDO
@@ -6281,7 +6403,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ifld=IAVBLFLD(IGET(273))
fld_info(cfld)%lvl1=L
fld_info(cfld)%lvl2=LM+1
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
@@ -6289,7 +6411,7 @@ SUBROUTINE SURFCE
! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR MASS REQUESTED FOR CMAQ
IF (IGET(503)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=AKHSAVG(I,J)
ENDDO
ENDDO
@@ -6311,14 +6433,14 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR WIND REQUESTED FOR CMAQ
IF (IGET(504)>0) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
GRID1(I,J)=AKMSAVG(I,J)
ENDDO
ENDDO
@@ -6340,7 +6462,7 @@ SUBROUTINE SURFCE
fld_info(cfld)%ntrange=0
endif
fld_info(cfld)%tinvstat=IFHR-ID(18)
- datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
+ datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend)
endif
ENDIF
@@ -6354,7 +6476,8 @@ subroutine qpf_comp(igetfld,compfile,fcst)
! compfile: file name for reference grid.
! fcst: forecast length in hours.
use ctlblk_mod, only: SPVAL,JSTA,JEND,IM,DTQ2,IFHR,IFMIN,TPREC,GRIB, &
- MODELNAME,JM,CFLD,DATAPD,FLD_INFO,JSTA_2L,JEND_2U
+ MODELNAME,JM,CFLD,DATAPD,FLD_INFO,JSTA_2L,JEND_2U,&
+ ISTA,IEND,ISTA_2L,IEND_2U
use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD
use grib2_module, only: read_grib2_head, read_grib2_sngle
use vrbls2d, only: AVGPREC, AVGPREC_CONT
@@ -6373,7 +6496,7 @@ subroutine qpf_comp(igetfld,compfile,fcst)
logical :: file_exists
- integer :: i, j, k, jj
+ integer :: i, j, k, ii, jj
! Read in reference grid.
INQUIRE(FILE=compfile, EXIST=file_exists)
@@ -6416,7 +6539,7 @@ subroutine qpf_comp(igetfld,compfile,fcst)
! !$omp parallel do private(i,j)
IF (file_exists) THEN
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (IFHR .EQ. 0 .OR. fcst .EQ. 0) THEN
outgrid(I,J) = 0.0
ELSE IF (mscValue(I,J) .LE. 0.0) THEN
@@ -6468,11 +6591,12 @@ subroutine qpf_comp(igetfld,compfile,fcst)
fld_info(cfld)%ifld=IAVBLFLD(IGET(igetfld))
fld_info(cfld)%ntrange=trange
fld_info(cfld)%tinvstat=invstat
-!$omp parallel do private(i,j,jj)
+!$omp parallel do private(i,j,ii,jj)
do j=1,jend-jsta+1
jj = jsta+j-1
- do i=1,im
- datapd(i,j,cfld) = outgrid(i,jj)
+ do i=1,iend-ista+1
+ ii = ista+i-1
+ datapd(i,j,cfld) = outgrid(ii,jj)
enddo
enddo
endif
diff --git a/sorc/ncep_post.fd/TRPAUS.f b/sorc/ncep_post.fd/TRPAUS.f
index 2523717b5..24a27d71d 100644
--- a/sorc/ncep_post.fd/TRPAUS.f
+++ b/sorc/ncep_post.fd/TRPAUS.f
@@ -1,53 +1,37 @@
!> @file
-!
-!> SUBPROGRAM: TRPAUS COMPUTE TROPOPAUSE DATA.
-!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22
-!!
-!! ABSTRACT:
-!! THIS ROUTINE COMPUTES TROPOPAUSE DATA. AT EACH MASS
-!! POINT A SURFACE UP SEARCH IS MADE FOR THE FIRST
-!! OCCURRENCE OF A THREE LAYER MEAN LAPSE RATE LESS THAN
-!! OR EQUAL TO A CRITICAL LAPSE RATE. THIS CRITCAL LAPSE
-!! RATE IS 2DEG/KM. THIS IS IN ACCORD WITH THE WMO
-!! DEFINITION OF A TROPOPAUSE. A MAXIMUM TROPOPAUSE
-!! PRESSURE OF 500MB IS ENFORCED. ONC THE TROPOPAUSE
-!! IS LOCATED IN A COLUMN, PRESSURE, TEMPERATURE, U
-!! AND V WINDS, AND VERTICAL WIND SHEAR ARE COMPUTED.
-!!
-!! PROGRAM HISTORY LOG:
-!! 92-12-22 RUSS TREADON
-!! 97-03-06 GEOFF MANIKIN - CHANGED CRITERIA FOR DETERMINING
-!! THE TROPOPAUSE AND ADDED HEIGHT
-!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D
-!! 00-01-04 JIM TUCCILLO - MPI VERSION
-!! 02-04-23 MIKE BALDWIN - WRF VERSION
-!! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT
+!> @brief trpaus() computes tropopause data.
+!>
+!> @author Russ Treadon W/NP2 @date 1992-12-22
-!!
-!! USAGE: CALL TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP)
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! PTROP - TROPOPAUSE PRESSURE.
-!! TTROP - TROPOPAUSE TEMPERATURE.
-!! ZTROP - TROPOPAUSE HEIGHT
-!! UTROP - TROPOPAUSE U WIND COMPONENT.
-!! VTROP - TROPOPAUSE V WIND COMPONENT.
-!! SHTROP - VERTICAL WIND SHEAR AT TROPOPAUSE.
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!!
-!! LIBRARY:
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
+!> This routine computes tropopause data. At each mass
+!> point a surface up search is made for the first
+!> occurrence of a three layer mean lapse rate less than
+!> or equal to a critical lapse rate. This critcal lapse
+!> rate is 2deg/km. This is in accord with the WMO
+!> definition of a tropopause. A maximum tropopause
+!> pressure of 500mb is enforced. Onc the tropopause
+!> is located in a column, pressure, temperature, u
+!> and v winds, and vertical wind shear are computed.
+!>
+!> @param[out] PTROP Tropopause pressure.
+!> @param[out] TTROP Tropopause temperature.
+!> @param[out] ZTROP Tropopause height.
+!> @param[out] UTROP Tropopause u wind component.
+!> @param[out] VTROP Tropopause v wind component.
+!> @param[out] SHTROP Vertical wind shear at tropopause.
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1992-12-22 | Russ Treadon | Initial
+!> 1997-03-06 | Geoff Manikin | Changed criteria for determining the tropopause and added height
+!> 1998-06-15 | T Black | Conversion from 1-D TO 2-D
+!> 2000-01-04 | Jim Tuccillo | MPI Version
+!> 2002-04-23 | Mike Baldwin | WRF Version
+!> 2019-10-30 | Bo Cui | ReMOVE "GOTO" STATEMENT
+!> 2021-09-13 | JESSE MENG | 2D DECOMPOSITION
+!>
+!> @author Russ Treadon W/NP2 @date 1992-12-22
SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP)
!
@@ -57,7 +41,8 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP)
use vrbls3d, only: pint, t, zint, uh, vh
use masks, only: lmh
use params_mod, only: d50
- use ctlblk_mod, only: jsta, jend, spval, im, jm, lm
+ use ctlblk_mod, only: jsta, jend, spval, im, jm, lm, &
+ ista, iend
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
!
@@ -82,7 +67,7 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP)
! LOOP OVER THE HORIZONTAL GRID.
!
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
PTROP(I,J) = SPVAL
TTROP(I,J) = SPVAL
ZTROP(I,J) = SPVAL
@@ -97,7 +82,7 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP)
!!$omp& tlapse,tlapse2,u0,u0l,uh,uh0,ul,
!!$omp& v0,v0l,vh,vh0)
DO J=JSTA,JEND
- loopI:DO I=1,IM
+ loopI:DO I=ISTA,IEND
!
! COMPUTE THE TEMPERATURE LAPSE RATE (-DT/DZ) BETWEEN ETA
! LAYERS MOVING UP FROM THE GROUND. THE FIRST ETA LAYER
diff --git a/sorc/ncep_post.fd/TRPAUS_NAM.f b/sorc/ncep_post.fd/TRPAUS_NAM.f
index caf8785f4..7ea734f58 100644
--- a/sorc/ncep_post.fd/TRPAUS_NAM.f
+++ b/sorc/ncep_post.fd/TRPAUS_NAM.f
@@ -1,43 +1,37 @@
!> @file
-!
-!> SUBPROGRAM: TRPAUS COMPUTE TROPOPAUSE DATA.
-!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22
-!!
-!! ABSTRACT:
-!! THIS ROUTINE COMPUTES TROPOPAUSE DATA. AT EACH MASS
-!! POINT A SURFACE UP SEARCH IS MADE FOR THE FIRST
-!! OCCURRENCE OF A THREE LAYER MEAN LAPSE RATE LESS THAN
-!! OR EQUAL TO A CRITICAL LAPSE RATE. THIS CRITCAL LAPSE
-!! RATE IS 2DEG/KM. THIS IS IN ACCORD WITH THE WMO
-!! DEFINITION OF A TROPOPAUSE. A MAXIMUM TROPOPAUSE
-!! PRESSURE OF 500MB IS ENFORCED. ONC THE TROPOPAUSE
-!! IS LOCATED IN A COLUMN, PRESSURE, TEMPERATURE, U
-!! AND V WINDS, AND VERTICAL WIND SHEAR ARE COMPUTED.
-!!
-!! PROGRAM HISTORY LOG:
-!! - 92-12-22 RUSS TREADON
-!! - 97-03-06 GEOFF MANIKIN - CHANGED CRITERIA FOR DETERMINING
-!! THE TROPOPAUSE AND ADDED HEIGHT
-!! - 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D
-!! - 00-01-04 JIM TUCCILLO - MPI VERSION
-!! - 02-04-23 MIKE BALDWIN - WRF VERSION
-!! - 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT
-!!
-!! USAGE: CALL TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP)
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! PTROP - TROPOPAUSE PRESSURE.
-!! TTROP - TROPOPAUSE TEMPERATURE.
-!! ZTROP - TROPOPAUSE HEIGHT
-!! UTROP - TROPOPAUSE U WIND COMPONENT.
-!! VTROP - TROPOPAUSE V WIND COMPONENT.
-!! SHTROP - VERTICAL WIND SHEAR AT TROPOPAUSE.
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
+!> @brief trpaus() computes tropopause data.
+!>
+!> @author Russ Treadon W/NP2 @date 1992-12-22
+
+!> This routine computes tropopause data. At each mass
+!> point a surface up search is made for the first
+!> occurrence of a three layer mean lapse rate less than
+!> or equal to a critical lapse rate. This critcal lapse
+!> rate is 2deg/km. This is in accord with the WMO
+!> definition of a tropopause. A maximum tropopause
+!> pressure of 500mb is enforced. Onc the tropopause
+!> is located in a column, pressure, temperature, u
+!> and v winds, and vertical wind shear are computed.
+!>
+!> @param[out] PTROP Tropopause pressure.
+!> @param[out] TTROP Tropopause temperature.
+!> @param[out] ZTROP Tropopause height.
+!> @param[out] UTROP Tropopause u wind component.
+!> @param[out] VTROP Tropopause v wind component.
+!> @param[out] SHTROP Vertical wind shear at tropopause.
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1992-12-22 | Russ Treadon | Initial
+!> 1997-03-06 | Geoff Manikin | Changed criteria for determining the tropopause and added height
+!> 1998-06-15 | T Black | Conversion from 1-D TO 2-D
+!> 2000-01-04 | Jim Tuccillo | MPI Version
+!> 2002-04-23 | Mike Baldwin | WRF Version
+!> 2019-10-30 | Bo Cui | ReMOVE "GOTO" STATEMENT
+!> 2021-09-13 | JESSE MENG | 2D DECOMPOSITION
+!>
+!> @author Russ Treadon W/NP2 @date 1992-12-22
SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP)
!
@@ -59,8 +53,8 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP)
!
! DECLARE VARIABLES.
!
- REAL PTROP(IM,JM),TTROP(IM,JM),ZTROP(IM,JM),UTROP(IM,JM)
- REAL VTROP(IM,JM),SHTROP(IM,JM)
+ REAL PTROP(ISTA:IEND,JSTA:JEND),TTROP(ISTA:IEND,JSTA:JEND),ZTROP(ISTA:IEND,JSTA:JEND),UTROP(ISTA:IEND,JSTA:JEND)
+ REAL VTROP(ISTA:IEND,JSTA:JEND),SHTROP(ISTA:IEND,JSTA:JEND)
REAL TLAPSE(LM),DZ2(LM),DELT2(LM),TLAPSE2(LM)
!
integer I,J
@@ -72,7 +66,7 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP)
! LOOP OVER THE HORIZONTAL GRID.
!
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
PTROP(I,J) = SPVAL
TTROP(I,J) = SPVAL
ZTROP(I,J) = SPVAL
@@ -87,7 +81,7 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP)
!$omp& tlapse,tlapse2,u0,u0l,uh,uh0,ul,
!$omp& v0,v0l,vh,vh0)
DO J=JSTA,JEND
- loopI:DO I=1,IM
+ loopI:DO I=ISTA,IEND
!
! COMPUTE THE TEMPERATURE LAPSE RATE (-DT/DZ) BETWEEN ETA
! LAYERS MOVING UP FROM THE GROUND. THE FIRST ETA LAYER
diff --git a/sorc/ncep_post.fd/TTBLEX.f b/sorc/ncep_post.fd/TTBLEX.f
index 21748a6f4..5dad0ae76 100644
--- a/sorc/ncep_post.fd/TTBLEX.f
+++ b/sorc/ncep_post.fd/TTBLEX.f
@@ -19,6 +19,7 @@ SUBROUTINE TTBLEX(TREF,TTBL,ITB,JTB,KARR,PMIDL &
! 00-01-04 JIM TUCCILLO - MPI VERSION
! 01-10-22 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT
! 02-01-15 MIKE BALDWIN - WRF VERSION
+! 21-09-13 J MENG - 2D DECOMPOSITION
!
! OUTPUT FILES:
! NONE
@@ -30,20 +31,21 @@ SUBROUTINE TTBLEX(TREF,TTBL,ITB,JTB,KARR,PMIDL &
! ATTRIBUTES:
! LANGUAGE: FORTRAN
!----------------------------------------------------------------------
- use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, me
+ use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, me, &
+ ista, iend, ista_2l, iend_2u
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
!----------------------------------------------------------------------
integer,intent(in) :: ITB,JTB
- integer,intent(in) :: KARR(IM,jsta:jend)
+ integer,intent(in) :: KARR(ista:iend,jsta:jend)
real,dimension(JTB,ITB),intent(in) :: TTBL
- real,dimension(IM,JSTA_2L:JEND_2U),intent(in) :: PMIDL
- real,dimension(IM,JSTA_2L:JEND_2U),intent(out) :: TREF
- real,dimension(IM,jsta:jend),intent(out) :: QQ,PP
- real,dimension(IM,jsta:jend),intent(in) :: THESP
+ real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(in) :: PMIDL
+ real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(out) :: TREF
+ real,dimension(ista:iend,jsta:jend),intent(out) :: QQ,PP
+ real,dimension(ista:iend,jsta:jend),intent(in) :: THESP
real,dimension(ITB), intent(in) :: THE0,STHE
- integer,dimension(IM,jsta:jend),intent(out) :: IPTB,ITHTB
+ integer,dimension(ista:iend,jsta:jend),intent(out) :: IPTB,ITHTB
real,intent(in) :: PL,RDP,RDTHE
!
@@ -55,7 +57,7 @@ SUBROUTINE TTBLEX(TREF,TTBL,ITB,JTB,KARR,PMIDL &
!$omp& private(i,j,bthe00k,bthe10k,bthk,ip,iptbk,ith,pk,sthe00k,sthe10k,&
!$omp& sthk,t00k,t01k,t10k,t11k,tpk,tthk)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(KARR(I,J) > 0) THEN
!--------------SCALING PRESSURE & TT TABLE INDEX------------------------
PK = PMIDL(I,J)
diff --git a/sorc/ncep_post.fd/UPP_MATH.f b/sorc/ncep_post.fd/UPP_MATH.f
index 2b1ad4a75..a19eaf06d 100644
--- a/sorc/ncep_post.fd/UPP_MATH.f
+++ b/sorc/ncep_post.fd/UPP_MATH.f
@@ -1,25 +1,25 @@
!> @file
-!
-!> SUBPROGRAM: UPP_MATH
-!! @author JMENG @date 2020-05-20
-!!
-!! A collection of UPP subroutines for numerical math functions calculation.
-!!
-!! DVDXDUDY
-!! computes dudy, dvdx, uwnd
-!!
-!! H2U, H2V, U2H, V2H
-!! interpolates variables between U, V, H, points
-!! adopted from UPP subroutine GRIDAVG.f
-!!
-!! PROGRAM HISTORY LOG:
-!! MAY 20 2020 Jesse Meng Initial code
-!!------------------------------------------------------------------------
-!!
+!>
+!> @brief upp_math is a collection of UPP subroutines for numerical math functions calculation.
+!> @author Jesse Meng @date 2020-05-20
+
+!> dvdxdudy() computes dudy, dvdx, uwnd
+!>
+!> h2u(), h2v(), u2h(), v2h() interpolate variables between U, V, H, points
+!> adopted from UPP subroutine GRIDAVG.f
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2020-05-20 | Jesse Meng | Initial
+!> 2022-06-10 | Wen Meng | Modify dvdxdudy to retrict computation on undefined grids
+!>
+!> @author Jesse Meng @date 2020-05-20
module upp_math
use masks, only: dx, dy
- use ctlblk_mod, only: im, jsta_2l, jend_2u, jsta_m, jend_m, spval
+ use ctlblk_mod, only: im, jsta_2l, jend_2u, jsta_m, jend_m, spval,&
+ ista_2l, iend_2u, ista_m, iend_m
use gridspec_mod, only: gridtype
!
implicit none
@@ -43,20 +43,31 @@ subroutine dvdxdudy(uwnd,vwnd)
!
implicit none
- REAL, dimension(im,jsta_2l:jend_2u), intent(in) :: UWND, VWND
+ REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: UWND, VWND
!
!-- local variables
!--
integer i, j
real r2dx, r2dy
INTEGER, allocatable :: IHE(:),IHW(:)
-!
+
+!Initializing
+ DO J=JSTA_M,JEND_M
+ DO I=ISTA_M,IEND_M
+ DDVDX(I,J)=SPVAL
+ DDUDY(I,J)=SPVAL
+ UUAVG(I,J)=SPVAL
+ ENDDO
+ ENDDO
+
IF(GRIDTYPE == 'A')THEN
!$omp parallel do private(i,j,r2dx,r2dy)
DO J=JSTA_M,JEND_M
- DO I=2,IM-1
- IF(VWND(I+1,J)1.E-5.AND.ABS(DY(I,J))>1.E-5) THEN
R2DX = 1./(2.*DX(I,J))
R2DY = 1./(2.*DY(I,J))
DDVDX(I,J) = (VWND(I+1,J)-VWND(I-1,J))*R2DX
@@ -74,7 +85,7 @@ subroutine dvdxdudy(uwnd,vwnd)
ENDDO
!$omp parallel do private(i,j,r2dx,r2dy)
DO J=JSTA_M,JEND_M
- DO I=2,IM-1
+ DO I=ISTA_M,IEND_M
IF(VWND(I+IHE(J),J) < SPVAL.AND.VWND(I+IHW(J),J) < SPVAL .AND. &
& UWND(I,J+1) < SPVAL .AND.UWND(I,J-1) < SPVAL) THEN
R2DX = 1./(2.*DX(I,J))
@@ -90,7 +101,7 @@ subroutine dvdxdudy(uwnd,vwnd)
ELSE IF (GRIDTYPE == 'B')THEN
!$omp parallel do private(i,j,r2dx,r2dy)
DO J=JSTA_M,JEND_M
- DO I=2,IM-1
+ DO I=ISTA_M,IEND_M
R2DX = 1./DX(I,J)
R2DY = 1./DY(I,J)
if(VWND(I, J)==SPVAL .or. VWND(I, J-1)==SPVAL .or. &
@@ -115,51 +126,51 @@ subroutine H2U(ingrid,outgrid)
! This subroutine interpolates from H points onto U points
! Author: CHUANG, EMC, Dec. 2010
- use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend, me, num_procs, jm,&
- im, jsta_2l, jend_2u , jend_m
+ use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, me, num_procs, jm,&
+ im, jsta_2l, jend_2u, ista, iend, ista_m, iend_m, ista_2l, iend_2u
use gridspec_mod, only: gridtype
implicit none
INCLUDE "mpif.h"
integer:: i,j,ie,iw
- real,dimension(IM,JSTA_2L:JEND_2U),intent(in)::ingrid
- real,dimension(IM,JSTA_2L:JEND_2U),intent(out)::outgrid
+ real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(in)::ingrid
+ real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(out)::outgrid
outgrid=spval
if(GRIDTYPE == 'A')THEN
do j=jsta,jend
- do i=1,im
+ do i=ista,iend
outgrid(i,j)=ingrid(i,j)
end do
end do
else IF(GRIDTYPE == 'E')THEN
- call exch(ingrid(1,jsta_2l))
+ call exch(ingrid(ista_2l,jsta_2l))
DO J=JSTA_M,JEND_M
- DO I=2,IM-1
+ DO I=ISTA_M,IEND_M
IE=I+MOD(J,2)
IW=IE-1
outgrid(i,j)=(ingrid(IW,J)+ingrid(IE,J)+ingrid(I,J+1)+ingrid(I,J-1))/4.0
end do
end do
ELSE IF(GRIDTYPE == 'B')THEN
- call exch(ingrid(1,jsta_2l))
+ call exch(ingrid(ista_2l,jsta_2l))
DO J=JSTA,JEND_M
- DO I=1,IM-1
+ DO I=ISTA,IEND_M
outgrid(i,j)=(ingrid(i,j)+ingrid(i,j+1)+ingrid(i+1,j)+ingrid(i+1,j+1))/4.0
end do
end do
! Fill in boundary points because hysplit fails when 10 m wind has bitmaps
do j=jsta,jend_m
- outgrid(im,j)=outgrid(im-1,j)
+ outgrid(iend,j)=outgrid(iend-1,j)
end do
IF(me == (num_procs-1) .and. jend_2u >= jm) then
- DO I=1,IM
- outgrid(i,jm) = outgrid(i,jm-1)
+ DO I=ISTA,IEND
+ outgrid(i,jend) = outgrid(i,jend-1)
END DO
END IF
ELSE IF(GRIDTYPE == 'C')THEN
DO J=JSTA,JEND
- DO I=1,IM-1
+ DO I=ISTA,IEND_M
outgrid(i,j)=(ingrid(i,j)+ingrid(i+1,j))/2.0
end do
end do
@@ -172,40 +183,41 @@ end subroutine H2U
subroutine H2V(ingrid,outgrid)
! This subroutine interpolates from H points onto V points
! Author: CHUANG, EMC, Dec. 2010
- use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, im, jsta_2l, jend_2u
+ use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, im, jsta_2l, jend_2u,&
+ ista, iend, ista_m, iend_m, ista_2l, iend_2u
use gridspec_mod, only: gridtype
implicit none
INCLUDE "mpif.h"
integer:: i,j,ie,iw
- real,dimension(IM,JSTA_2L:JEND_2U),intent(in)::ingrid
- real,dimension(IM,JSTA_2L:JEND_2U),intent(out)::outgrid
+ real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(in)::ingrid
+ real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(out)::outgrid
outgrid=spval
if(GRIDTYPE == 'A')THEN
do j=jsta,jend
- do i=1,im
+ do i=ista,iend
outgrid(i,j)=ingrid(i,j)
end do
end do
else IF(GRIDTYPE == 'E')THEN
- call exch(ingrid(1,jsta_2l))
+ call exch(ingrid(ista_2l,jsta_2l))
DO J=JSTA_M,JEND_M
- DO I=2,IM-1
+ DO I=ISTA_M,IEND_M
IE=I+MOD(J,2)
IW=IE-1
outgrid(i,j)=(ingrid(IW,J)+ingrid(IE,J)+ingrid(I,J+1)+ingrid(I,J-1))/4.0
end do
end do
ELSE IF(GRIDTYPE == 'B')THEN
- call exch(ingrid(1,jsta_2l))
+ call exch(ingrid(ista_2l,jsta_2l))
DO J=JSTA,JEND_M
- DO I=1,IM-1
+ DO I=ISTA,IEND_M
outgrid(i,j)=(ingrid(i,j)+ingrid(i,j+1)+ingrid(i+1,j)+ingrid(i+1,j+1))/4.0
end do
end do
ELSE IF(GRIDTYPE == 'C')THEN
- call exch(ingrid(1,jsta_2l))
+ call exch(ingrid(ista_2l,jsta_2l))
DO J=JSTA,JEND_M
- DO I=1,IM
+ DO I=ISTA,IEND
outgrid(i,j)=(ingrid(i,j)+ingrid(i,j+1))/2.0
end do
end do
@@ -218,39 +230,40 @@ end subroutine H2V
subroutine U2H(ingrid,outgrid)
! This subroutine interpolates from U points onto H points
! Author: CHUANG, EMC, Dec. 2010
- use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, im, jsta_2l, jend_2u
+ use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, im, jsta_2l, jend_2u,&
+ ista, iend, ista_m, iend_m, ista_2l, iend_2u
use gridspec_mod, only: gridtype
implicit none
INCLUDE "mpif.h"
integer:: i,j,ie,iw
- real,dimension(IM,JSTA_2L:JEND_2U),intent(in)::ingrid
- real,dimension(IM,JSTA_2L:JEND_2U),intent(out)::outgrid
+ real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(in)::ingrid
+ real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(out)::outgrid
outgrid=spval
if(GRIDTYPE == 'A')THEN
do j=jsta,jend
- do i=1,im
+ do i=ista,iend
outgrid(i,j)=ingrid(i,j)
end do
end do
else IF(GRIDTYPE == 'E')THEN
- call exch(ingrid(1,jsta_2l))
+ call exch(ingrid(ista_2l,jsta_2l))
DO J=JSTA_M,JEND_M
- DO I=2,IM-1
+ DO I=ISTA_M,IEND_M
IE=I+MOD(J+1,2)
IW=IE-1
outgrid(i,j)=(ingrid(IW,J)+ingrid(IE,J)+ingrid(I,J+1)+ingrid(I,J-1))/4.0
end do
end do
ELSE IF(GRIDTYPE == 'B')THEN
- call exch(ingrid(1,jsta_2l))
+ call exch(ingrid(ista_2l,jsta_2l))
DO J=JSTA_M,JEND_M
- DO I=2,IM-1
+ DO I=ISTA_M,IEND_M
outgrid(i,j)=(ingrid(i-1,j-1)+ingrid(i,j-1)+ingrid(i-1,j)+ingrid(i,j))/4.0
end do
end do
ELSE IF(GRIDTYPE == 'C')THEN
DO J=JSTA,JEND
- DO I=2,IM
+ DO I=ISTA_M,IEND
outgrid(i,j)=(ingrid(i-1,j)+ingrid(i,j))/2.0
end do
end do
@@ -263,40 +276,41 @@ end subroutine U2H
subroutine V2H(ingrid,outgrid)
! This subroutine interpolates from V points onto H points
! Author: CHUANG, EMC, Dec. 2010
- use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, im, jsta_2l, jend_2u
+ use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, im, jsta_2l, jend_2u,&
+ ista, iend, ista_m, iend_m, ista_2l, iend_2u
use gridspec_mod, only: gridtype
implicit none
INCLUDE "mpif.h"
integer:: i,j,ie,iw
- real,dimension(IM,JSTA_2L:JEND_2U),intent(in)::ingrid
- real,dimension(IM,JSTA_2L:JEND_2U),intent(out)::outgrid
+ real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(in)::ingrid
+ real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(out)::outgrid
outgrid=spval
if(GRIDTYPE == 'A')THEN
do j=jsta,jend
- do i=1,im
+ do i=ista,iend
outgrid(i,j)=ingrid(i,j)
end do
end do
else IF(GRIDTYPE == 'E')THEN
- call exch(ingrid(1,jsta_2l))
+ call exch(ingrid(ista_2l,jsta_2l))
DO J=JSTA_M,JEND_M
- DO I=2,IM-1
+ DO I=ISTA_M,IEND_M
IE=I+MOD(J,2)
IW=IE-1
outgrid(i,j)=(ingrid(IW,J)+ingrid(IE,J)+ingrid(I,J+1)+ingrid(I,J-1))/4.0
end do
end do
ELSE IF(GRIDTYPE == 'B')THEN
- call exch(ingrid(1,jsta_2l))
+ call exch(ingrid(ista_2l,jsta_2l))
DO J=JSTA_M,JEND_M
- DO I=2,IM-1
+ DO I=ISTA_M,IEND_M
outgrid(i,j)=(ingrid(i-1,j-1)+ingrid(i,j-1)+ingrid(i-1,j)+ingrid(i,j))/4.0
end do
end do
ELSE IF(GRIDTYPE == 'C')THEN
- call exch(ingrid(1,jsta_2l))
+ call exch(ingrid(ista_2l,jsta_2l))
DO J=JSTA_M,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
outgrid(i,j)=(ingrid(i,j-1)+ingrid(i,j))/2.0
end do
end do
diff --git a/sorc/ncep_post.fd/UPP_PHYSICS.f b/sorc/ncep_post.fd/UPP_PHYSICS.f
index 60a54dee5..cc609aabf 100644
--- a/sorc/ncep_post.fd/UPP_PHYSICS.f
+++ b/sorc/ncep_post.fd/UPP_PHYSICS.f
@@ -1,37 +1,29 @@
!> @file
-!
-!> SUBPROGRAM: UPP_PHYSICS
-!! @author JMENG @date 2020-05-20
-!!
-!! A collection of UPP subroutines for physics variables calculation.
-!!
-!! CALCAPE
-!! Compute CAPE/CINS and other storm related variables.
-!!
-!! CALCAPE2
-!! Compute additional storm related variables.
-!!
-!! CALRH
-!! CALRH_NAM
-!! CALRH_GFS
-!! CALRH_GSD
-!! Compute RH using various algorithms.
-!! The NAM v4.1.18 ALGORITHM (CALRH_NAM) is selected as default for
-!! NMMB and FV3GFS, FV3GEFS, and FV3R for the UPP 2020 unification.
-!!
-!! CALRH_PW
-!! Algorithm use at GSD for RUC and Rapid Refresh
-!!
-!! FPVSNEW
-!! Compute saturation vapor pressure.
-!!
-!! TVIRTUAL
-!! Compute virtual temperature.
-!!
-!! PROGRAM HISTORY LOG:
-!! MAY, 2020 Jesse Meng Initial code
-!!-------------------------------------------------------------------------------------
-!!
+!>
+!> @brief upp_physics is a collection of UPP subroutines for physics variables calculation.
+!> @author Jesse Meng @date 2020-05-20
+
+!> calcape() computes CAPE/CINS and other storm related variables.
+!>
+!> calcape2() computes additional storm related variables.
+!>
+!> calrh(), calrh_nam(), calrh_gfs(), calrh_gsd() compute RH using various algorithms.
+!>
+!> The NAM v4.1.18 algorithm (calrh_nam()) is selected as default for
+!> NMMB and FV3GFS, FV3GEFS, and FV3R for the UPP 2020 unification.
+!>
+!> calrh_pw() algorithm use at GSD for RUC and Rapid Refresh.
+!>
+!> fpvsnew() computes saturation vapor pressure.
+!>
+!> tvirtual() computes virtual temperature.
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2020-05-20 | Jesse Meng | Initial
+!>
+!> @author Jesse Meng @date 2020-05-20
module upp_physics
implicit none
@@ -39,9 +31,13 @@ module upp_physics
private
public :: CALCAPE, CALCAPE2
+ public :: CALDIV
+ public :: CALGRADPS
public :: CALRH
public :: CALRH_GFS, CALRH_GSD, CALRH_NAM
public :: CALRH_PW
+ public :: CALVOR
+
public :: FPVSNEW
public :: TVIRTUAL
@@ -51,12 +47,12 @@ module upp_physics
!
SUBROUTINE CALRH(P1,T1,Q1,RH)
- use ctlblk_mod, only: im, jsta, jend, MODELNAME
+ use ctlblk_mod, only: ista, iend, jsta, jend, MODELNAME
implicit none
- REAL,dimension(IM,jsta:jend),intent(in) :: P1,T1
- REAL,dimension(IM,jsta:jend),intent(inout) :: Q1
- REAL,dimension(IM,jsta:jend),intent(out) :: RH
+ REAL,dimension(ista:iend,jsta:jend),intent(in) :: P1,T1
+ REAL,dimension(ista:iend,jsta:jend),intent(inout) :: Q1
+ REAL,dimension(ista:iend,jsta:jend),intent(out) :: RH
IF(MODELNAME == 'RAPR')THEN
CALL CALRH_GSD(P1,T1,Q1,RH)
@@ -68,57 +64,37 @@ END SUBROUTINE CALRH
!
!-------------------------------------------------------------------------------------
!
- SUBROUTINE CALRH_NAM(P1,T1,Q1,RH)
-! SUBROUTINE CALRH(P1,T1,Q1,RH)
-!$$$ SUBPROGRAM DOCUMENTATION BLOCK
-! . . .
-! SUBPROGRAM: CALRH COMPUTES RELATIVE HUMIDITY
-! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22
-!
-! ABSTRACT:
-! THIS ROUTINE COMPUTES RELATIVE HUMIDITY GIVEN PRESSURE,
-! TEMPERATURE, SPECIFIC HUMIDITY. AN UPPER AND LOWER BOUND
-! OF 100 AND 1 PERCENT RELATIVE HUMIDITY IS ENFORCED. WHEN
-! THESE BOUNDS ARE APPLIED THE PASSED SPECIFIC HUMIDITY
-! ARRAY IS ADJUSTED AS NECESSARY TO PRODUCE THE SET RELATIVE
-! HUMIDITY.
-! .
-!
-! PROGRAM HISTORY LOG:
-! ??-??-?? DENNIS DEAVEN
-! 92-12-22 RUSS TREADON - MODIFIED AS DESCRIBED ABOVE.
-! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D
-! 98-08-18 MIKE BALDWIN - MODIFY TO COMPUTE RH OVER ICE AS IN MODEL
-! 98-12-16 GEOFF MANIKIN - UNDO RH COMPUTATION OVER ICE
-! 00-01-04 JIM TUCCILLO - MPI VERSION
-! 02-06-11 MIKE BALDWIN - WRF VERSION
-! 06-03-19 Wen Meng - MODIFY TOP PRESSURE to 1 PA
-!
-! USAGE: CALL CALRH(P1,T1,Q1,RH)
-! INPUT ARGUMENT LIST:
-! P1 - PRESSURE (PA)
-! T1 - TEMPERATURE (K)
-! Q1 - SPECIFIC HUMIDITY (KG/KG)
-!
-! OUTPUT ARGUMENT LIST:
-! RH - RELATIVE HUMIDITY (DECIMAL FORM)
-! Q1 - ADJUSTED SPECIFIC HUMIDITY (KG/KG)
-!
-! OUTPUT FILES:
-! NONE
-!
-! SUBPROGRAMS CALLED:
-! UTILITIES:
-! LIBRARY:
-! NONE
-!
-! ATTRIBUTES:
-! LANGUAGE: FORTRAN
-! MACHINE : CRAY C-90
-!$$$
-!
+!> calrh_nam() computes relative humidity.
+!>
+!> This routine computes relative humidity given pressure,
+!> temperature, specific humidity. an upper and lower bound
+!> of 100 and 1 percent relative humidity is enforced. When
+!> these bounds are applied the passed specific humidity
+!> array is adjusted as necessary to produce the set relative
+!> humidity.
+!>
+!> @param[in] P1 Pressure (pa)
+!> @param[in] T1 Temperature (K)
+!> @param[in] Q1 Specific humidity (kg/kg)
+!> @param[out] RH Relative humidity (decimal form)
+!> @param[out] Q1 Specific humidity (kg/kg)
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> ????-??-?? | DENNIS DEAVEN | Initial
+!> 1992-12-22 | Russ Treadon | Modified as described above
+!> 1998-06-08 | T Black | Conversion from 1-D to 2-D
+!> 1998-08-18 | Mike Baldwin | Modify to compute RH over ice as in model
+!> 1998-12-16 | Geoff Manikin | undo RH computation over ice
+!> 2000-01-04 | Jim Tuccillo | MPI Version
+!> 2002-06-11 | Mike Baldwin | WRF Version
+!> 2006-03-19 | Wen Meng | Modify top pressure to 1 pa
+!>
+!> @author Russ Treadon W/NP2 @date 1992-12-22
+ SUBROUTINE CALRH_NAM(P1,T1,Q1,RH)
use params_mod, only: PQ0, a2, a3, a4, rhmin
- use ctlblk_mod, only: jsta, jend, spval, im
+ use ctlblk_mod, only: ista, iend, jsta, jend, spval
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
!
@@ -126,9 +102,9 @@ SUBROUTINE CALRH_NAM(P1,T1,Q1,RH)
!
! DECLARE VARIABLES.
!
- REAL,dimension(IM,jsta:jend),intent(in) :: P1,T1
- REAL,dimension(IM,jsta:jend),intent(inout) :: Q1
- REAL,dimension(IM,jsta:jend),intent(out) :: RH
+ REAL,dimension(ista:iend,jsta:jend),intent(in) :: P1,T1
+ REAL,dimension(ista:iend,jsta:jend),intent(inout) :: Q1
+ REAL,dimension(ista:iend,jsta:jend),intent(out) :: RH
REAL QC
integer I,J
!***************************************************************
@@ -136,7 +112,7 @@ SUBROUTINE CALRH_NAM(P1,T1,Q1,RH)
! START CALRH.
!
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (T1(I,J) < spval) THEN
IF (ABS(P1(I,J)) >= 1) THEN
QC = PQ0/P1(I,J)*EXP(A2*(T1(I,J)-A3)/(T1(I,J)-A4))
@@ -167,57 +143,38 @@ END SUBROUTINE CALRH_NAM
!
!-------------------------------------------------------------------------------------
!
+!> calrh_gfs() computes relative humidity.
+!>
+!> This routine computes relative humidity given pressure,
+!> temperature, specific humidity. an upper and lower bound
+!> of 100 and 1 percent relative humidity is enforced. When
+!> these bounds are applied the passed specific humidity
+!> array is adjusted as necessary to produce the set relative
+!> humidity.
+!>
+!> @param[in] P1 Pressure (pa)
+!> @param[in] T1 Temperature (K)
+!> @param[in] Q1 Specific humidity (kg/kg)
+!> @param[out] RH Relative humidity (decimal form)
+!> @param[out] Q1 Specific humidity (kg/kg)
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> ????-??-?? | DENNIS DEAVEN | Initial
+!> 1992-12-22 | Russ Treadon | Modified as described above
+!> 1998-06-08 | T Black | Conversion from 1-D to 2-D
+!> 1998-08-18 | Mike Baldwin | Modify to compute RH over ice as in model
+!> 1998-12-16 | Geoff Manikin | undo RH computation over ice
+!> 2000-01-04 | Jim Tuccillo | MPI Version
+!> 2002-06-11 | Mike Baldwin | WRF Version
+!> 2013-08-13 | S. Moorthi | Threading
+!> 2006-03-19 | Wen Meng | Modify top pressure to 1 pa
+!>
+!> @author Russ Treadon W/NP2 @date 1992-12-22
SUBROUTINE CALRH_GFS(P1,T1,Q1,RH)
-!$$$ SUBPROGRAM DOCUMENTATION BLOCK
-! . . .
-! SUBPROGRAM: CALRH COMPUTES RELATIVE HUMIDITY
-! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22
-!
-! ABSTRACT:
-! THIS ROUTINE COMPUTES RELATIVE HUMIDITY GIVEN PRESSURE,
-! TEMPERATURE, SPECIFIC HUMIDITY. AN UPPER AND LOWER BOUND
-! OF 100 AND 1 PERCENT RELATIVE HUMIDITY IS ENFORCED. WHEN
-! THESE BOUNDS ARE APPLIED THE PASSED SPECIFIC HUMIDITY
-! ARRAY IS ADJUSTED AS NECESSARY TO PRODUCE THE SET RELATIVE
-! HUMIDITY.
-! .
-!
-! PROGRAM HISTORY LOG:
-! ??-??-?? DENNIS DEAVEN
-! 92-12-22 RUSS TREADON - MODIFIED AS DESCRIBED ABOVE.
-! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D
-! 98-08-18 MIKE BALDWIN - MODIFY TO COMPUTE RH OVER ICE AS IN MODEL
-! 98-12-16 GEOFF MANIKIN - UNDO RH COMPUTATION OVER ICE
-! 00-01-04 JIM TUCCILLO - MPI VERSION
-! 02-06-11 MIKE BALDWIN - WRF VERSION
-! 13-08-13 S. Moorthi - Threading
-! 06-03-19 Wen Meng - MODIFY TOP PRESSURE to 1 PA
-!
-! USAGE: CALL CALRH(P1,T1,Q1,RH)
-! INPUT ARGUMENT LIST:
-! P1 - PRESSURE (PA)
-! T1 - TEMPERATURE (K)
-! Q1 - SPECIFIC HUMIDITY (KG/KG)
-!
-! OUTPUT ARGUMENT LIST:
-! RH - RELATIVE HUMIDITY (DECIMAL FORM)
-! Q1 - ADJUSTED SPECIFIC HUMIDITY (KG/KG)
-!
-! OUTPUT FILES:
-! NONE
-!
-! SUBPROGRAMS CALLED:
-! UTILITIES:
-! LIBRARY:
-! NONE
-!
-! ATTRIBUTES:
-! LANGUAGE: FORTRAN
-! MACHINE : CRAY C-90
-!$$$
-!
use params_mod, only: rhmin
- use ctlblk_mod, only: jsta, jend, spval, im
+ use ctlblk_mod, only: ista, iend, jsta, jend, spval
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
!
@@ -234,8 +191,8 @@ SUBROUTINE CALRH_GFS(P1,T1,Q1,RH)
! END FUNCTION FPVSNEW
! END INTERFACE
!
- REAL,dimension(IM,jsta:jend),intent(in) :: P1,T1
- REAL,dimension(IM,jsta:jend),intent(inout):: Q1,RH
+ REAL,dimension(ista:iend,jsta:jend),intent(in) :: P1,T1
+ REAL,dimension(ista:iend,jsta:jend),intent(inout):: Q1,RH
REAL ES,QC
integer :: I,J
!***************************************************************
@@ -244,7 +201,7 @@ SUBROUTINE CALRH_GFS(P1,T1,Q1,RH)
!
!$omp parallel do private(i,j,es,qc)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (T1(I,J) < spval .AND. P1(I,J) < spval.AND.Q1(I,J)/=spval) THEN
! IF (ABS(P1(I,J)) > 1.0) THEN
! IF (P1(I,J) > 1.0) THEN
@@ -284,17 +241,17 @@ SUBROUTINE CALRH_GSD(P1,T1,Q1,RHB)
!------------------------------------------------------------------
!
- use ctlblk_mod, only: jsta, jend, im, spval
+ use ctlblk_mod, only: ista, iend, jsta, jend, spval
implicit none
integer :: j, i
real :: tx, pol, esx, es, e
- real, dimension(im,jsta:jend) :: P1, T1, Q1, RHB
+ real, dimension(ista:iend,jsta:jend) :: P1, T1, Q1, RHB
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (T1(I,J) < spval .AND. P1(I,J) < spval .AND. Q1(I,J) < spval) THEN
! - compute relative humidity
Tx=T1(I,J)-273.15
@@ -326,13 +283,13 @@ SUBROUTINE CALRH_PW(RHPW)
use vrbls3d, only: q, pmid, t
use params_mod, only: g
- use ctlblk_mod, only: lm, jsta, jend, lm, im, spval
+ use ctlblk_mod, only: lm, ista, iend, jsta, jend, spval
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
real,PARAMETER :: svp1=6.1153,svp2=17.67,svp3=29.65
- REAL, dimension(im,jsta:jend):: PW, PW_SAT, RHPW
+ REAL, dimension(ista:iend,jsta:jend):: PW, PW_SAT, RHPW
REAL deltp,sh,qv,temp,es,qs,qv_sat
integer i,j,l,k,ka,kb
@@ -343,7 +300,7 @@ SUBROUTINE CALRH_PW(RHPW)
DO L=1,LM
k=lm-l+1
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
! -- use specific humidity for PW calculation
if(t(i,j,k) fpvsnew() computes saturation vapor pressure.
+!>
+!> Compute saturation vapor pressure from the temperature.
+!> A linear interpolation is done between values in a lookup table
+!> computed in gpvs. See documentation for fpvsx for details.
+!> Input values outside table range are reset to table extrema.
+!> The interpolation accuracy is almost 6 decimal places.
+!> On the Cray, fpvs is about 4 times faster than exact calculation.
+!> This function should be expanded inline in the calling routine.
+!>
+!> @param[in] t Real(krealfp) Temperature in Kelvin.
+!> @param[out] fpvsnew Real(krealfp) Saturation vapor pressure in Pascals.
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1991-05-07 | Iredell | Initial. Made into inlinable function
+!> 1994-12-30 | Iredell | Expand table
+!> 1999-03-01 | Iredell | F90 module
+!> 2001-02-26 | Iredell | Ice phase
+!>
+!> @author N Phillips w/NMC2X2 @date 1982-12-30
implicit none
integer,parameter:: nxpvs=7501
real,parameter:: con_ttp =2.7316e+2 ! temp at H2O 3pt
@@ -486,130 +434,98 @@ elemental function fpvsnew(t)
end function fpvsnew
!
!-------------------------------------------------------------------------------------
-!
-
+!> calcape() computes CAPE and CINS.
+!>
+!> This routine computes CAPE and CINS given temperature,
+!> pressure, and specific humidty. In "storm and cloud
+!> dynamics" (1989, academic press) cotton and anthes define
+!> CAPE (equation 9.16, p501) as
+!>
+!> @code
+!> EL
+!> CAPE = SUM G * LN(THETAP/THETAA) DZ
+!> LCL
+!>
+!> Where,
+!> EL = Equilibrium level,
+!> LCL = Lifting condenstation level,
+!> G = Gravitational acceleration,
+!> THETAP = Lifted parcel potential temperature,
+!> THETAA = Ambient potential temperature.
+!> @endcode
+!>
+!> Note that the integrand ln(THETAP/THETAA) approximately
+!> equals (THETAP-THETAA)/THETAA. This ratio is often used
+!> in the definition of CAPE/CINS.
+!>
+!> Two types of CAPE/CINS can be computed by this routine. The
+!> summation process is the same For both cases. What differs
+!> is the definition of the parcel to lift. FOR ITYPE=1 the
+!> parcel with the warmest THETA-E in A DPBND pascal layer above
+!> the model surface is lifted. the arrays P1D, T1D, and Q1D
+!> are not used. For itype=2 the arrays P1D, T1D, and Q1D
+!> define the parcel to lift in each column. Both types of
+!> CAPE/CINS may be computed in a single execution of the post
+!> processor.
+!>
+!> This algorithm proceeds as follows.
+!> For each column,
+!> (1) Initialize running CAPE and CINS SUM TO 0.0
+!> (2) Compute temperature and pressure at the LCL using
+!> look up table (PTBL). Use either parcel that gives
+!> max THETAE in lowest DPBND above ground (ITYPE=1)
+!> or given parcel from t1D,Q1D,...(ITYPE=2).
+!> (3) Compute the temp of a parcel lifted from the LCL.
+!> We know that the parcel's
+!> equivalent potential temperature (THESP) remains
+!> constant through this process. we can
+!> compute tpar using this knowledge using look
+!> up table (subroutine TTBLEX).
+!> (4) Find the equilibrium level. This is defined as the
+!> highest positively buoyant layer.
+!> (If there is no positively buoyant layer, CAPE/CINS
+!> will be zero)
+!> (5) Compute CAPE/CINS.
+!> (A) Compute THETAP. We know TPAR and P.
+!> (B) Compute THETAA. We know T and P.
+!> (6) Add G*(THETAP-THETAA)*DZ to the running CAPE or CINS sum.
+!> (A) If THETAP > THETAA, add to the CAPE sum.
+!> (B) If THETAP < THETAA, add to the CINS sum.
+!> (7) Are we at equilibrium level?
+!> (A) If yes, stop the summation.
+!> (b) if no, contiunue the summation.
+!> (8) Enforce limits on CAPE and CINS (i.e. no negative CAPE)
+!>
+!> @param[in] ITYPE INTEGER Flag specifying how parcel to lift is identified. See comments above.
+!> @param[in] DPBND Depth over which one searches for most unstable parcel.
+!> @param[in] P1D Array of pressure of parcels to lift.
+!> @param[in] T1D Array of temperature of parcels to lift.
+!> @param[in] Q1D Array of specific humidity of parcels to lift.
+!> @param[in] L1D Array of model level of parcels to lift.
+!> @param[out] CAPE Convective available potential energy (J/kg).
+!> @param[out] CINS Convective inhibition (J/kg).
+!> @param[out] PPARC Pressure level of parcel lifted when one searches over a particular depth to compute CAPE/CIN.
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1993-02-10 | Russ Treadon | Initial
+!> 1993-06-19 | Russ Treadon | Generalized routine to allow for type 2 CAPE/CINS calculations
+!> 1994-09-23 | Mike Baldwin | Modified to use look up tables instead of complicated equations
+!> 1994-10-13 | Mike Baldwin | Modified to continue CAPE/CINS calc up to at highest buoyant layer
+!> 1998-06-12 | T Black | Conversion from 1-D TO 2-D
+!> 1998-08-18 | T Black | Compute APE internally
+!> 2000-01-04 | Jim Tuccillo | MPI Version
+!> 2002-01-15 | Mike Baldwin | WRF Version
+!> 2003-08-24 | G Manikin | Added level of parcel being lifted as output from the routine and added the depth over which one searches for the most unstable parcel as input
+!> 2010-09-09 | G Manikin | Changed computation to use virtual temp added eq lvl hght and thunder parameter
+!> 2015-??-?? | S Moorthi | Optimization and threading
+!> 2021-07-28 | W Meng | Restrict computation from undefined grids
+!> 2021-09-01 | E Colon | Equivalent level height index for RTMA
+!>
+!> @author Russ Treadon W/NP2 @date 1993-02-10
SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
CINS,PPARC,ZEQL,THUND)
-!$$$ SUBPROGRAM DOCUMENTATION BLOCK
-! . . .
-! SUBPROGRAM: CALCAPE COMPUTES CAPE AND CINS
-! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-02-10
-!
-! ABSTRACT:
-!
-! THIS ROUTINE COMPUTES CAPE AND CINS GIVEN TEMPERATURE,
-! PRESSURE, AND SPECIFIC HUMIDTY. IN "STORM AND CLOUD
-! DYNAMICS" (1989, ACADEMIC PRESS) COTTON AND ANTHES DEFINE
-! CAPE (EQUATION 9.16, P501) AS
-!
-! EL
-! CAPE = SUM G * LN(THETAP/THETAA) DZ
-! LCL
-!
-! WHERE,
-! EL = EQUILIBRIUM LEVEL,
-! LCL = LIFTING CONDENSTATION LEVEL,
-! G = GRAVITATIONAL ACCELERATION,
-! THETAP = LIFTED PARCEL POTENTIAL TEMPERATURE,
-! THETAA = AMBIENT POTENTIAL TEMPERATURE.
-!
-! NOTE THAT THE INTEGRAND LN(THETAP/THETAA) APPROXIMATELY
-! EQUALS (THETAP-THETAA)/THETAA. THIS RATIO IS OFTEN USED
-! IN THE DEFINITION OF CAPE/CINS.
-!
-! TWO TYPES OF CAPE/CINS CAN BE COMPUTED BY THIS ROUTINE. THE
-! SUMMATION PROCESS IS THE SAME FOR BOTH CASES. WHAT DIFFERS
-! IS THE DEFINITION OF THE PARCEL TO LIFT. FOR ITYPE=1 THE
-! PARCEL WITH THE WARMEST THETA-E IN A DPBND PASCAL LAYER ABOVE
-! THE MODEL SURFACE IS LIFTED. THE ARRAYS P1D, T1D, AND Q1D
-! ARE NOT USED. FOR ITYPE=2 THE ARRAYS P1D, T1D, AND Q1D
-! DEFINE THE PARCEL TO LIFT IN EACH COLUMN. BOTH TYPES OF
-! CAPE/CINS MAY BE COMPUTED IN A SINGLE EXECUTION OF THE POST
-! PROCESSOR.
-!
-! THIS ALGORITHM PROCEEDS AS FOLLOWS.
-! FOR EACH COLUMN,
-! (1) INITIALIZE RUNNING CAPE AND CINS SUM TO 0.0
-! (2) COMPUTE TEMPERATURE AND PRESSURE AT THE LCL USING
-! LOOK UP TABLE (PTBL). USE EITHER PARCEL THAT GIVES
-! MAX THETAE IN LOWEST DPBND ABOVE GROUND (ITYPE=1)
-! OR GIVEN PARCEL FROM T1D,Q1D,...(ITYPE=2).
-! (3) COMPUTE THE TEMP OF A PARCEL LIFTED FROM THE LCL.
-! WE KNOW THAT THE PARCEL'S
-! EQUIVALENT POTENTIAL TEMPERATURE (THESP) REMAINS
-! CONSTANT THROUGH THIS PROCESS. WE CAN
-! COMPUTE TPAR USING THIS KNOWLEDGE USING LOOK
-! UP TABLE (SUBROUTINE TTBLEX).
-! (4) FIND THE EQUILIBRIUM LEVEL. THIS IS DEFINED AS THE
-! HIGHEST POSITIVELY BUOYANT LAYER.
-! (IF THERE IS NO POSITIVELY BUOYANT LAYER, CAPE/CINS
-! WILL BE ZERO)
-! (5) COMPUTE CAPE/CINS.
-! (A) COMPUTE THETAP. WE KNOW TPAR AND P.
-! (B) COMPUTE THETAA. WE KNOW T AND P.
-! (6) ADD G*(THETAP-THETAA)*DZ TO THE RUNNING CAPE OR CINS SUM.
-! (A) IF THETAP > THETAA, ADD TO THE CAPE SUM.
-! (B) IF THETAP < THETAA, ADD TO THE CINS SUM.
-! (7) ARE WE AT EQUILIBRIUM LEVEL?
-! (A) IF YES, STOP THE SUMMATION.
-! (B) IF NO, CONTIUNUE THE SUMMATION.
-! (8) ENFORCE LIMITS ON CAPE AND CINS (I.E. NO NEGATIVE CAPE)
-!
-! PROGRAM HISTORY LOG:
-! 93-02-10 RUSS TREADON
-! 93-06-19 RUSS TREADON - GENERALIZED ROUTINE TO ALLOW FOR
-! TYPE 2 CAPE/CINS CALCULATIONS.
-! 94-09-23 MIKE BALDWIN - MODIFIED TO USE LOOK UP TABLES
-! INSTEAD OF COMPLICATED EQUATIONS.
-! 94-10-13 MIKE BALDWIN - MODIFIED TO CONTINUE CAPE/CINS CALC
-! UP TO AT HIGHEST BUOYANT LAYER.
-! 98-06-12 T BLACK - CONVERSION FROM 1-D TO 2-D
-! 98-08-18 T BLACK - COMPUTE APE INTERNALLY
-! 00-01-04 JIM TUCCILLO - MPI VERSION
-! 02-01-15 MIKE BALDWIN - WRF VERSION
-! 03-08-24 G MANIKIN - ADDED LEVEL OF PARCEL BEING LIFTED
-! AS OUTPUT FROM THE ROUTINE AND ADDED
-! THE DEPTH OVER WHICH ONE SEARCHES FOR
-! THE MOST UNSTABLE PARCEL AS INPUT
-! 10-09-09 G MANIKIN - CHANGED COMPUTATION TO USE VIRTUAL TEMP
-! - ADDED EQ LVL HGHT AND THUNDER PARAMETER
-! 15-xx-xx S MOORTHI - optimization and threading
-! 21-07-28 W Meng - Restrict computation from undefined grids.
-! 21-09-01 E COLON - equivalent level height index for RTMA
-!
-! USAGE: CALL CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE,
-! CINS,PPARC)
-! INPUT ARGUMENT LIST:
-! ITYPE - INTEGER FLAG SPECIFYING HOW PARCEL TO LIFT IS
-! IDENTIFIED. SEE COMMENTS ABOVE.
-! DPBND - DEPTH OVER WHICH ONE SEARCHES FOR MOST UNSTABLE PARCEL
-! P1D - ARRAY OF PRESSURE OF PARCELS TO LIFT.
-! T1D - ARRAY OF TEMPERATURE OF PARCELS TO LIFT.
-! Q1D - ARRAY OF SPECIFIC HUMIDITY OF PARCELS TO LIFT.
-! L1D - ARRAY OF MODEL LEVEL OF PARCELS TO LIFT.
-!
-! OUTPUT ARGUMENT LIST:
-! CAPE - CONVECTIVE AVAILABLE POTENTIAL ENERGY (J/KG)
-! CINS - CONVECTIVE INHIBITION (J/KG)
-! PPARC - PRESSURE LEVEL OF PARCEL LIFTED WHEN ONE SEARCHES
-! OVER A PARTICULAR DEPTH TO COMPUTE CAPE/CIN
-!
-! OUTPUT FILES:
-! STDOUT - RUN TIME STANDARD OUT.
-!
-! SUBPROGRAMS CALLED:
-! UTILITIES:
-! BOUND - BOUND (CLIP) DATA BETWEEN UPPER AND LOWER LIMTS.
-! TTBLEX - LOOKUP TABLE ROUTINE TO GET T FROM THETAE AND P
-!
-! LIBRARY:
-! COMMON -
-!
-! ATTRIBUTES:
-! LANGUAGE: FORTRAN 90
-! MACHINE : CRAY C-90
-!$$$
-!
use vrbls3d, only: pmid, t, q, zint
use vrbls2d, only: teql,ieql
use masks, only: lmh
@@ -618,7 +534,8 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
use lookup_mod, only: thl, rdth, jtb, qs0, sqs, rdq, itb, ptbl, &
plq, ttbl, pl, rdp, the0, sthe, rdthe, ttblq, &
itbq, jtbq, rdpq, the0q, stheq, rdtheq
- use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, im, me, spval
+ use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, im, me, spval, &
+ ista_2l, iend_2u, ista, iend
!
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
@@ -630,16 +547,16 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
!
integer,intent(in) :: ITYPE
real,intent(in) :: DPBND
- integer, dimension(IM,Jsta:jend),intent(in) :: L1D
- real, dimension(IM,Jsta:jend),intent(in) :: P1D,T1D
- real, dimension(IM,jsta:jend),intent(inout) :: Q1D,CAPE,CINS,PPARC,ZEQL
+ integer, dimension(ista:iend,Jsta:jend),intent(in) :: L1D
+ real, dimension(ista:iend,Jsta:jend),intent(in) :: P1D,T1D
+ real, dimension(ista:iend,jsta:jend),intent(inout) :: Q1D,CAPE,CINS,PPARC,ZEQL
!
- integer, dimension(im,jsta:jend) :: IPTB, ITHTB, PARCEL, KLRES, KHRES, LCL, IDX
+ integer, dimension(ista:iend,jsta:jend) :: IPTB, ITHTB, PARCEL, KLRES, KHRES, LCL, IDX
!
- real, dimension(im,jsta:jend) :: THESP, PSP, CAPE20, QQ, PP, THUND
+ real, dimension(ista:iend,jsta:jend) :: THESP, PSP, CAPE20, QQ, PP, THUND
REAL, ALLOCATABLE :: TPAR(:,:,:)
- LOGICAL THUNDER(IM,jsta:jend), NEEDTHUN
+ LOGICAL THUNDER(ista:iend,jsta:jend), NEEDTHUN
real PSFCK,PKL,TBTK,QBTK,APEBTK,TTHBTK,TTHK,APESPK,TPSPK, &
BQS00K,SQS00K,BQS10K,SQS10K,BQK,SQK,TQK,PRESK,GDZKL,THETAP, &
THETAA,P00K,P10K,P01K,P11K,TTHESK,ESATP,QSATP,TVP,TV
@@ -651,7 +568,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
!**************************************************************
! START CALCAPE HERE.
!
- ALLOCATE(TPAR(IM,JSTA_2L:JEND_2U,LM))
+ ALLOCATE(TPAR(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM))
!
! COMPUTE CAPE/CINS
!
@@ -675,7 +592,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
!
!$omp parallel do
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
CAPE(I,J) = D00
CAPE20(I,J) = D00
CINS(I,J) = D00
@@ -692,7 +609,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
!$omp parallel do
DO L=1,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
TPAR(I,J,L) = D00
ENDDO
ENDDO
@@ -705,7 +622,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
IF (ITYPE == 2) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
Q1D(I,J) = MIN(MAX(H1M12,Q1D(I,J)),H99999)
ENDDO
ENDDO
@@ -722,7 +639,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
!$omp & p00k,p01k,p10k,p11k,pkl,psfck,qbtk,sqk,sqs00k, &
!$omp & sqs10k,tbtk,tpspk,tqk,tthbtk,tthesk,tthk)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
PSFCK = PMID(I,J,NINT(LMH(I,J)))
PKL = PMID(I,J,KB)
IF(PSFCK NINT(LMH(I,J))) LCL(I,J) = NINT(LMH(I,J))
IF (ITYPE > 2) THEN
IF (T(I,J,LCL(I,J)) < 263.15) THEN
@@ -850,7 +767,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
KNUML = 0
KNUMH = 0
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
KLRES(I,J) = 0
KHRES(I,J) = 0
IF(L <= LCL(I,J)) THEN
@@ -868,23 +785,23 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
!*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE 0) THEN
- CALL TTBLEX(TPAR(1,JSTA_2L,L),TTBL,ITB,JTB,KLRES &
- , PMID(1,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE &
+ CALL TTBLEX(TPAR(ISTA_2L,JSTA_2L,L),TTBL,ITB,JTB,KLRES &
+ , PMID(ISTA_2L,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE &
, RDTHE,THESP,IPTB,ITHTB)
ENDIF
!***
!*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PLQ
!**
IF(KNUMH > 0) THEN
- CALL TTBLEX(TPAR(1,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES &
- , PMID(1,JSTA_2L,L),PLQ,QQ,PP,RDPQ &
+ CALL TTBLEX(TPAR(ISTA_2L,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES &
+ , PMID(ISTA_2L,JSTA_2L,L),PLQ,QQ,PP,RDPQ &
,THE0Q,STHEQ,RDTHEQ,THESP,IPTB,ITHTB)
ENDIF
!------------SEARCH FOR EQ LEVEL----------------------------------------
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(KHRES(I,J) > 0) THEN
IF(TPAR(I,J,L) > T(I,J,L)) IEQL(I,J) = L
ENDIF
@@ -893,7 +810,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(KLRES(I,J) > 0) THEN
IF(TPAR(I,J,L) > T(I,J,L) .AND. &
PMID(I,J,L)>100.) IEQL(I,J) = L
@@ -906,7 +823,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
LBEG = 1000
LEND = 0
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
LBEG = MIN(IEQL(I,J),LBEG)
LEND = MAX(LCL(I,J),LEND)
ENDDO
@@ -914,7 +831,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T(I,J,IEQL(I,J)) > 255.65) THEN
THUNDER(I,J) = .FALSE.
ENDIF
@@ -925,7 +842,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IDX(I,J) = 0
IF(L >= IEQL(I,J).AND.L <= LCL(I,J)) THEN
IDX(I,J) = 1
@@ -935,7 +852,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
!
!$omp parallel do private(i,j,gdzkl,presk,thetaa,thetap,esatp,qsatp,tvp,tv)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(IDX(I,J) > 0) THEN
PRESK = PMID(I,J,L)
GDZKL = (ZINT(I,J,L)-ZINT(I,J,L+1)) * G
@@ -966,7 +883,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
CAPE(I,J) = MAX(D00,CAPE(I,J))
CINS(I,J) = MIN(CINS(I,J),D00)
! add equillibrium height
@@ -988,140 +905,104 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
END SUBROUTINE CALCAPE
!
!-------------------------------------------------------------------------------------
-!
+!> calcape2() computes CAPE and CINS.
+!>
+!> This routine computes CAPE and CINS given temperature,
+!> pressure, and specific humidty. In "storm and cloud
+!> dynamics" (1989, academic press) cotton and anthes define
+!> CAPE (equation 9.16, p501) as
+!>
+!> @code
+!> EL
+!> CAPE = SUM G * ln(THETAP/THETAA) DZ
+!> LCL
+!>
+!> Where,
+!> EL = Equilibrium level,
+!> LCL = Lifting condenstation level,
+!> G = Gravitational acceleration,
+!> THETAP = Lifted parcel potential temperature,
+!> THETAA = Ambient potential temperature.
+!> @endcode
+!>
+!> Note that the integrand ln(THETAP/THETAA) approximately
+!> equals (THETAP-THETAA)/THETAA. This ratio is often used
+!> in the definition of CAPE/CINS.
+!>
+!> Two types of CAPE/CINS can be computed by this routine. The
+!> summation process is the same For both cases. What differs
+!> is the definition of the parcel to lift. FOR ITYPE=1 the
+!> parcel with the warmest THETA-E in A DPBND pascal layer above
+!> the model surface is lifted. the arrays P1D, T1D, and Q1D
+!> are not used. For itype=2 the arrays P1D, T1D, and Q1D
+!> define the parcel to lift in each column. Both types of
+!> CAPE/CINS may be computed in a single execution of the post
+!> processor.
+!>
+!> This algorithm proceeds as follows.
+!> For each column,
+!> (1) Initialize running CAPE and CINS SUM TO 0.0
+!> (2) Compute temperature and pressure at the LCL using
+!> look up table (PTBL). Use either parcel that gives
+!> max THETAE in lowest DPBND above ground (ITYPE=1)
+!> or given parcel from t1D,Q1D,...(ITYPE=2).
+!> (3) Compute the temp of a parcel lifted from the LCL.
+!> We know that the parcel's
+!> equivalent potential temperature (THESP) remains
+!> constant through this process. we can
+!> compute tpar using this knowledge using look
+!> up table (subroutine TTBLEX).
+!> (4) Find the equilibrium level. This is defined as the
+!> highest positively buoyant layer.
+!> (If there is no positively buoyant layer, CAPE/CINS
+!> will be zero)
+!> (5) Compute CAPE/CINS.
+!> (A) Compute THETAP. We know TPAR and P.
+!> (B) Compute THETAA. We know T and P.
+!> (6) Add G*(THETAP-THETAA)*DZ to the running CAPE or CINS sum.
+!> (A) If THETAP > THETAA, add to the CAPE sum.
+!> (B) If THETAP < THETAA, add to the CINS sum.
+!> (7) Are we at equilibrium level?
+!> (A) If yes, stop the summation.
+!> (b) if no, contiunue the summation.
+!> (8) Enforce limits on CAPE and CINS (i.e. no negative CAPE)
+!>
+!> @param[in] ITYPE INTEGER Flag specifying how parcel to lift is identified. See comments above.
+!> @param[in] DPBND Depth over which one searches for most unstable parcel.
+!> @param[in] P1D Array of pressure of parcels to lift.
+!> @param[in] T1D Array of temperature of parcels to lift.
+!> @param[in] Q1D Array of specific humidity of parcels to lift.
+!> @param[in] L1D Array of model level of parcels to lift.
+!> @param[out] CAPE Convective available potential energy (J/kg).
+!> @param[out] CINS Convective inhibition (J/kg).
+!> @param[out] LFC level of free convection (m).
+!> @param[out] ESRHL Lower bound to account for effective helicity calculation.
+!> @param[out] ESRHH Upper bound to account for effective helicity calculation.
+!> @param[out] DCAPE downdraft CAPE (J/KG).
+!> @param[out] DGLD Dendritic growth layer depth (m).
+!> @param[out] ESP Enhanced stretching potential.
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1993-02-10 | Russ Treadon | Initial
+!> 1993-06-19 | Russ Treadon | Generalized routine to allow for type 2 CAPE/CINS calculations
+!> 1994-09-23 | Mike Baldwin | Modified to use look up tables instead of complicated equations
+!> 1994-10-13 | Mike Baldwin | Modified to continue CAPE/CINS calc up to at highest buoyant layer
+!> 1998-06-12 | T Black | Conversion from 1-D TO 2-D
+!> 1998-08-18 | T Black | Compute APE internally
+!> 2000-01-04 | Jim Tuccillo | MPI Version
+!> 2002-01-15 | Mike Baldwin | WRF Version
+!> 2003-08-24 | G Manikin | Added level of parcel being lifted as output from the routine and added the depth over which one searches for the most unstable parcel as input
+!> 2010-09-09 | G Manikin | Changed computation to use virtual temp added eq lvl hght and thunder parameter
+!> 2015-??-?? | S Moorthi | Optimization and threading
+!> 2021-09-03 | J Meng | Modified to add 0-3km CAPE/CINS, LFC, effective helicity, downdraft CAPE, dendritic growth layer depth, ESP
+!> 2021-09-01 | E Colon | Equivalent level height index for RTMA
+!>
+!> @author Russ Treadon W/NP2 @date 1993-02-10
SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
CAPE,CINS,LFC,ESRHL,ESRHH, &
DCAPE,DGLD,ESP)
-! SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
-! CINS,PPARC,ZEQL,THUND)
-!$$$ SUBPROGRAM DOCUMENTATION BLOCK
-! . . .
-! SUBPROGRAM: CALCAPE COMPUTES CAPE AND CINS
-! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-02-10
-!
-! ABSTRACT:
-!
-! THIS ROUTINE COMPUTES CAPE AND CINS GIVEN TEMPERATURE,
-! PRESSURE, AND SPECIFIC HUMIDTY. IN "STORM AND CLOUD
-! DYNAMICS" (1989, ACADEMIC PRESS) COTTON AND ANTHES DEFINE
-! CAPE (EQUATION 9.16, P501) AS
-!
-! EL
-! CAPE = SUM G * LN(THETAP/THETAA) DZ
-! LCL
-!
-! WHERE,
-! EL = EQUILIBRIUM LEVEL,
-! LCL = LIFTING CONDENSTATION LEVEL,
-! G = GRAVITATIONAL ACCELERATION,
-! THETAP = LIFTED PARCEL POTENTIAL TEMPERATURE,
-! THETAA = AMBIENT POTENTIAL TEMPERATURE.
-!
-! NOTE THAT THE INTEGRAND LN(THETAP/THETAA) APPROXIMATELY
-! EQUALS (THETAP-THETAA)/THETAA. THIS RATIO IS OFTEN USED
-! IN THE DEFINITION OF CAPE/CINS.
-!
-! TWO TYPES OF CAPE/CINS CAN BE COMPUTED BY THIS ROUTINE. THE
-! SUMMATION PROCESS IS THE SAME FOR BOTH CASES. WHAT DIFFERS
-! IS THE DEFINITION OF THE PARCEL TO LIFT. FOR ITYPE=1 THE
-! PARCEL WITH THE WARMEST THETA-E IN A DPBND PASCAL LAYER ABOVE
-! THE MODEL SURFACE IS LIFTED. THE ARRAYS P1D, T1D, AND Q1D
-! ARE NOT USED. FOR ITYPE=2 THE ARRAYS P1D, T1D, AND Q1D
-! DEFINE THE PARCEL TO LIFT IN EACH COLUMN. BOTH TYPES OF
-! CAPE/CINS MAY BE COMPUTED IN A SINGLE EXECUTION OF THE POST
-! PROCESSOR.
-!
-! THIS ALGORITHM PROCEEDS AS FOLLOWS.
-! FOR EACH COLUMN,
-! (1) INITIALIZE RUNNING CAPE AND CINS SUM TO 0.0
-! (2) COMPUTE TEMPERATURE AND PRESSURE AT THE LCL USING
-! LOOK UP TABLE (PTBL). USE EITHER PARCEL THAT GIVES
-! MAX THETAE IN LOWEST DPBND ABOVE GROUND (ITYPE=1)
-! OR GIVEN PARCEL FROM T1D,Q1D,...(ITYPE=2).
-! (3) COMPUTE THE TEMP OF A PARCEL LIFTED FROM THE LCL.
-! WE KNOW THAT THE PARCEL'S
-! EQUIVALENT POTENTIAL TEMPERATURE (THESP) REMAINS
-! CONSTANT THROUGH THIS PROCESS. WE CAN
-! COMPUTE TPAR USING THIS KNOWLEDGE USING LOOK
-! UP TABLE (SUBROUTINE TTBLEX).
-! (4) FIND THE EQUILIBRIUM LEVEL. THIS IS DEFINED AS THE
-! HIGHEST POSITIVELY BUOYANT LAYER.
-! (IF THERE IS NO POSITIVELY BUOYANT LAYER, CAPE/CINS
-! WILL BE ZERO)
-! (5) COMPUTE CAPE/CINS.
-! (A) COMPUTE THETAP. WE KNOW TPAR AND P.
-! (B) COMPUTE THETAA. WE KNOW T AND P.
-! (6) ADD G*(THETAP-THETAA)*DZ TO THE RUNNING CAPE OR CINS SUM.
-! (A) IF THETAP > THETAA, ADD TO THE CAPE SUM.
-! (B) IF THETAP < THETAA, ADD TO THE CINS SUM.
-! (7) ARE WE AT EQUILIBRIUM LEVEL?
-! (A) IF YES, STOP THE SUMMATION.
-! (B) IF NO, CONTIUNUE THE SUMMATION.
-! (8) ENFORCE LIMITS ON CAPE AND CINS (I.E. NO NEGATIVE CAPE)
-!
-! PROGRAM HISTORY LOG:
-! 93-02-10 RUSS TREADON
-! 93-06-19 RUSS TREADON - GENERALIZED ROUTINE TO ALLOW FOR
-! TYPE 2 CAPE/CINS CALCULATIONS.
-! 94-09-23 MIKE BALDWIN - MODIFIED TO USE LOOK UP TABLES
-! INSTEAD OF COMPLICATED EQUATIONS.
-! 94-10-13 MIKE BALDWIN - MODIFIED TO CONTINUE CAPE/CINS CALC
-! UP TO AT HIGHEST BUOYANT LAYER.
-! 98-06-12 T BLACK - CONVERSION FROM 1-D TO 2-D
-! 98-08-18 T BLACK - COMPUTE APE INTERNALLY
-! 00-01-04 JIM TUCCILLO - MPI VERSION
-! 02-01-15 MIKE BALDWIN - WRF VERSION
-! 03-08-24 G MANIKIN - ADDED LEVEL OF PARCEL BEING LIFTED
-! AS OUTPUT FROM THE ROUTINE AND ADDED
-! THE DEPTH OVER WHICH ONE SEARCHES FOR
-! THE MOST UNSTABLE PARCEL AS INPUT
-! 10-09-09 G MANIKIN - CHANGED COMPUTATION TO USE VIRTUAL TEMP
-! - ADDED EQ LVL HGHT AND THUNDER PARAMETER
-! 15-xx-xx S MOORTHI - optimization and threading
-! 19-09-03 J MENG - MODIFIED TO ADD 0-3KM CAPE/CINS, LFC,
-! EFFECTIVE HELICITY, DOWNDRAFT CAPE,
-! DENDRITIC GROWTH LAYER DEPTH, ESP
-! 21-09-01 E COLON - equivalent level height index for RTMA
-!
-! USAGE: CALL CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
-! CAPE,CINS,LFC,ESRHL,ESRHH, &
-! DCAPE,DGLD,ESP)
-!
-! INPUT ARGUMENT LIST:
-! ITYPE - INTEGER FLAG SPECIFYING HOW PARCEL TO LIFT IS
-! IDENTIFIED. SEE COMMENTS ABOVE.
-! DPBND - DEPTH OVER WHICH ONE SEARCHES FOR MOST UNSTABLE PARCEL
-! P1D - ARRAY OF PRESSURE OF PARCELS TO LIFT.
-! T1D - ARRAY OF TEMPERATURE OF PARCELS TO LIFT.
-! Q1D - ARRAY OF SPECIFIC HUMIDITY OF PARCELS TO LIFT.
-! L1D - ARRAY OF MODEL LEVEL OF PARCELS TO LIFT.
-!
-! OUTPUT ARGUMENT LIST:
-! CAPE - CONVECTIVE AVAILABLE POTENTIAL ENERGY (J/KG)
-! CINS - CONVECTIVE INHIBITION (J/KG)
-! LFC - LEVEL OF FREE CONVECTION (M)
-! ESRHL - LOWER BOUND TO ACCOUNT FOR EFFECTIVE HELICITY CALCULATION
-! ESRHH - UPPER BOUND TO ACCOUNT FOR EFFECTIVE HELICITY CALCULATION
-! DCAPE - DOWNDRAFT CAPE (J/KG)
-! DGLD - DENDRITIC GROWTH LAYER DEPTH (M)
-! ESP - ENHANCED STRETCHING POTENTIAL
-!
-! OUTPUT FILES:
-! STDOUT - RUN TIME STANDARD OUT.
-!
-! SUBPROGRAMS CALLED:
-! UTILITIES:
-! BOUND - BOUND (CLIP) DATA BETWEEN UPPER AND LOWER LIMTS.
-! TTBLEX - LOOKUP TABLE ROUTINE TO GET T FROM THETAE AND P
-!
-! LIBRARY:
-! COMMON -
-!
-! ATTRIBUTES:
-! LANGUAGE: FORTRAN 90
-! MACHINE : CRAY C-90
-!$$$
-!
use vrbls3d, only: pmid, t, q, zint
use vrbls2d, only: fis,ieql
use gridspec_mod, only: gridtype
@@ -1131,7 +1012,8 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
use lookup_mod, only: thl, rdth, jtb, qs0, sqs, rdq, itb, ptbl, &
plq, ttbl, pl, rdp, the0, sthe, rdthe, ttblq, &
itbq, jtbq, rdpq, the0q, stheq, rdtheq
- use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, im, jm, me, jsta_m, jend_m, spval
+ use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, im, jm, me, jsta_m, jend_m, spval,&
+ ista_2l, iend_2u, ista, iend, ista_m, iend_m
!
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
@@ -1143,25 +1025,25 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!
integer,intent(in) :: ITYPE
real,intent(in) :: DPBND
- integer, dimension(IM,Jsta:jend),intent(in) :: L1D
- real, dimension(IM,Jsta:jend),intent(in) :: P1D,T1D
-! real, dimension(IM,jsta:jend),intent(inout) :: Q1D,CAPE,CINS,PPARC,ZEQL
- real, dimension(IM,jsta:jend),intent(inout) :: Q1D,CAPE,CINS
- real, dimension(IM,jsta:jend) :: PPARC,ZEQL
- real, dimension(IM,jsta:jend),intent(inout) :: LFC,ESRHL,ESRHH
- real, dimension(IM,jsta:jend),intent(inout) :: DCAPE,DGLD,ESP
- integer, dimension(im,jsta:jend) ::L12,L17,L3KM
+ integer, dimension(ista:iend,Jsta:jend),intent(in) :: L1D
+ real, dimension(ista:iend,Jsta:jend),intent(in) :: P1D,T1D
+! real, dimension(ista:iend,jsta:jend),intent(inout) :: Q1D,CAPE,CINS,PPARC,ZEQL
+ real, dimension(ista:iend,jsta:jend),intent(inout) :: Q1D,CAPE,CINS
+ real, dimension(ista:iend,jsta:jend) :: PPARC,ZEQL
+ real, dimension(ista:iend,jsta:jend),intent(inout) :: LFC,ESRHL,ESRHH
+ real, dimension(ista:iend,jsta:jend),intent(inout) :: DCAPE,DGLD,ESP
+ integer, dimension(ista:iend,jsta:jend) ::L12,L17,L3KM
!
- integer, dimension(im,jsta:jend) :: IPTB, ITHTB, PARCEL, KLRES, KHRES, LCL, IDX
+ integer, dimension(ista:iend,jsta:jend) :: IPTB, ITHTB, PARCEL, KLRES, KHRES, LCL, IDX
!
- real, dimension(im,jsta:jend) :: THESP, PSP, CAPE20, QQ, PP, THUND
- integer, dimension(im,jsta:jend) :: PARCEL2
- real, dimension(im,jsta:jend) :: THESP2,PSP2
- real, dimension(im,jsta:jend) :: CAPE4,CINS4
+ real, dimension(ista:iend,jsta:jend) :: THESP, PSP, CAPE20, QQ, PP, THUND
+ integer, dimension(ista:iend,jsta:jend) :: PARCEL2
+ real, dimension(ista:iend,jsta:jend) :: THESP2,PSP2
+ real, dimension(ista:iend,jsta:jend) :: CAPE4,CINS4
REAL, ALLOCATABLE :: TPAR(:,:,:)
REAL, ALLOCATABLE :: TPAR2(:,:,:)
- LOGICAL THUNDER(IM,jsta:jend), NEEDTHUN
+ LOGICAL THUNDER(ista:iend,jsta:jend), NEEDTHUN
real PSFCK,PKL,TBTK,QBTK,APEBTK,TTHBTK,TTHK,APESPK,TPSPK, &
BQS00K,SQS00K,BQS10K,SQS10K,BQK,SQK,TQK,PRESK,GDZKL,THETAP, &
THETAA,P00K,P10K,P01K,P11K,TTHESK,ESATP,QSATP,TVP,TV
@@ -1170,15 +1052,15 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
integer I,J,L,KNUML,KNUMH,LBEG,LEND,IQ, KB,ITTBK
integer IE,IW,JN,JS,IVE(JM),IVW(JM),JVN,JVS
integer ISTART,ISTOP,JSTART,JSTOP
- real, dimension(IM,jsta:jend) :: HTSFC
+ real, dimension(ista:iend,jsta:jend) :: HTSFC
! integer I,J,L,KNUML,KNUMH,LBEG,LEND,IQ,IT,LMHK, KB,ITTBK
!
!**************************************************************
! START CALCAPE HERE.
!
- ALLOCATE(TPAR(IM,JSTA_2L:JEND_2U,LM))
- ALLOCATE(TPAR2(IM,JSTA_2L:JEND_2U,LM))
+ ALLOCATE(TPAR(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM))
+ ALLOCATE(TPAR2(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM))
!
! COMPUTE CAPE/CINS
!
@@ -1202,7 +1084,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!
!$omp parallel do
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
CAPE(I,J) = D00
CAPE20(I,J) = D00
CAPE4(I,J) = D00
@@ -1230,7 +1112,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!$omp parallel do
DO L=1,LM
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
TPAR(I,J,L) = D00
TPAR2(I,J,L) = D00
ENDDO
@@ -1246,8 +1128,8 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
IVE(J) = MOD(J,2)
IVW(J) = IVE(J)-1
enddo
- ISTART = 2
- ISTOP = IM-1
+ ISTART = ISTA_M
+ ISTOP = IEND_M
JSTART = JSTA_M
JSTOP = JEND_M
ELSE IF(gridtype == 'B')THEN
@@ -1257,8 +1139,8 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
IVE(J)=1
IVW(J)=0
enddo
- ISTART = 2
- ISTOP = IM-1
+ ISTART = ISTA_M
+ ISTOP = IEND_M
JSTART = JSTA_M
JSTOP = JEND_M
ELSE
@@ -1268,13 +1150,13 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
IVE(J) = 0
IVW(J) = 0
enddo
- ISTART = 1
- ISTOP = IM
+ ISTART = ISTA
+ ISTOP = IEND
JSTART = JSTA
JSTOP = JEND
END IF
!!$omp parallel do private(htsfc,ie,iw)
- IF(gridtype /= 'A') CALL EXCH(FIS(1:IM,JSTA:JEND))
+ IF(gridtype /= 'A') CALL EXCH(FIS(ISTA:IEND,JSTA:JEND))
DO J=JSTART,JSTOP
DO I=ISTART,ISTOP
IE = I+IVE(J)
@@ -1299,7 +1181,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
IF (ITYPE == 2) THEN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
Q1D(I,J) = MIN(MAX(H1M12,Q1D(I,J)),H99999)
ENDDO
ENDDO
@@ -1316,7 +1198,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!$omp & p00k,p01k,p10k,p11k,pkl,psfck,qbtk,sqk,sqs00k, &
!$omp & sqs10k,tbtk,tpspk,tqk,tthbtk,tthesk,tthk)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
PSFCK = PMID(I,J,NINT(LMH(I,J)))
PKL = PMID(I,J,KB)
@@ -1412,7 +1294,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!----FIND THE PRESSURE OF THE PARCEL THAT WAS LIFTED
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
PPARC(I,J) = PMID(I,J,PARCEL(I,J))
ENDDO
ENDDO
@@ -1423,14 +1305,14 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
DO L=1,LM
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (PMID(I,J,L) < PSP(I,J)) LCL(I,J) = L+1
ENDDO
ENDDO
ENDDO
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF (LCL(I,J) > NINT(LMH(I,J))) LCL(I,J) = NINT(LMH(I,J))
IF (ITYPE > 2) THEN
IF (T(I,J,LCL(I,J)) < 263.15) THEN
@@ -1447,7 +1329,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
KNUML = 0
KNUMH = 0
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
KLRES(I,J) = 0
KHRES(I,J) = 0
IF(L <= LCL(I,J)) THEN
@@ -1465,23 +1347,23 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE 0) THEN
- CALL TTBLEX(TPAR(1,JSTA_2L,L),TTBL,ITB,JTB,KLRES &
- , PMID(1,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE &
+ CALL TTBLEX(TPAR(ISTA_2L,JSTA_2L,L),TTBL,ITB,JTB,KLRES &
+ , PMID(ISTA_2L,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE &
, RDTHE,THESP,IPTB,ITHTB)
ENDIF
!***
!*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PLQ
!**
IF(KNUMH > 0) THEN
- CALL TTBLEX(TPAR(1,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES &
- , PMID(1,JSTA_2L,L),PLQ,QQ,PP,RDPQ &
+ CALL TTBLEX(TPAR(ISTA_2L,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES &
+ , PMID(ISTA_2L,JSTA_2L,L),PLQ,QQ,PP,RDPQ &
,THE0Q,STHEQ,RDTHEQ,THESP,IPTB,ITHTB)
ENDIF
!------------SEARCH FOR EQ LEVEL----------------------------------------
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(KHRES(I,J) > 0) THEN
IF(TPAR(I,J,L) > T(I,J,L)) IEQL(I,J) = L
ENDIF
@@ -1490,7 +1372,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(KLRES(I,J) > 0) THEN
IF(TPAR(I,J,L) > T(I,J,L)) IEQL(I,J) = L
ENDIF
@@ -1502,7 +1384,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
LBEG = 1000
LEND = 0
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
LBEG = MIN(IEQL(I,J),LBEG)
LEND = MAX(LCL(I,J),LEND)
ENDDO
@@ -1510,7 +1392,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T(I,J,IEQL(I,J)) > 255.65) THEN
THUNDER(I,J) = .FALSE.
ENDIF
@@ -1526,7 +1408,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IDX(I,J) = 0
IF(L >= IEQL(I,J).AND.L <= LCL(I,J)) THEN
IDX(I,J) = 1
@@ -1537,7 +1419,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!$omp parallel do private(i,j,gdzkl,presk,thetaa,thetap,esatp,qsatp,tvp,tv,&
!$omp & presk2,esatp2,qsatp2,tvp2,thetap2,tv2,thetaa2)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(IDX(I,J) > 0) THEN
PRESK = PMID(I,J,L)
GDZKL = (ZINT(I,J,L)-ZINT(I,J,L+1)) * G
@@ -1598,7 +1480,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(ESRHH(I,J) > ESRHL(I,J)) ESRHH(I,J)=IEQL(I,J)
ENDDO
ENDDO
@@ -1609,7 +1491,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
CAPE(I,J) = MAX(D00,CAPE(I,J))
CINS(I,J) = MIN(CINS(I,J),D00)
! equillibrium height
@@ -1637,7 +1519,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
KNUML = 0
KNUMH = 0
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
KLRES(I,J) = 0
KHRES(I,J) = 0
PSFCK = PMID(I,J,NINT(LMH(I,J)))
@@ -1657,16 +1539,16 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE 0) THEN
- CALL TTBLEX(TPAR2(1,JSTA_2L,L),TTBL,ITB,JTB,KLRES &
- , PMID(1,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE &
+ CALL TTBLEX(TPAR2(ISTA_2L,JSTA_2L,L),TTBL,ITB,JTB,KLRES &
+ , PMID(ISTA_2L,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE &
, RDTHE,THESP2,IPTB,ITHTB)
ENDIF
!***
!*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PLQ
!**
IF(KNUMH > 0) THEN
- CALL TTBLEX(TPAR2(1,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES &
- , PMID(1,JSTA_2L,L),PLQ,QQ,PP,RDPQ &
+ CALL TTBLEX(TPAR2(ISTA_2L,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES &
+ , PMID(ISTA_2L,JSTA_2L,L),PLQ,QQ,PP,RDPQ &
, THE0Q,STHEQ,RDTHEQ,THESP2,IPTB,ITHTB)
ENDIF
ENDDO ! end of do l=lm,1,-1 loop
@@ -1677,7 +1559,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
DO L=LBEG,LEND
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IDX(I,J) = 0
IF(L >= PARCEL2(I,J).AND.L < NINT(LMH(I,J))) THEN
IDX(I,J) = 1
@@ -1687,7 +1569,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!
!$omp parallel do private(i,j,gdzkl,presk,thetaa,thetap,esatp,qsatp,tvp,tv)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(IDX(I,J) > 0) THEN
PRESK = PMID(I,J,L)
GDZKL = (ZINT(I,J,L)-ZINT(I,J,L+1)) * G
@@ -1709,7 +1591,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
DCAPE(I,J) = MIN(D00,DCAPE(I,J))
ENDDO
ENDDO
@@ -1725,7 +1607,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
DO L=LM,1,-1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(T(I,J,L) <= TFRZ-12. .AND. L12(I,J)==LM) L12(I,J)=L
IF(T(I,J,L) <= TFRZ-17. .AND. L17(I,J)==LM) L17(I,J)=L
ENDDO
@@ -1733,7 +1615,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
ENDDO
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(L12(I,J)/=LM .AND. L17(I,J)/=LM) THEN
DGLD(I,J)=ZINT(I,J,L17(I,J))-ZINT(I,J,L12(I,J))
DGLD(I,J)=MAX(DGLD(I,J),0.)
@@ -1749,14 +1631,14 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
DO L=LM,1,-1
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(ZINT(I,J,L)-HTSFC(I,J) <= 3000.) L3KM(I,J)=L
ENDDO
ENDDO
ENDDO
!$omp parallel do private(i,j)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
ESP(I,J) = (CAPE(I,J) / 50.) * (T(I,J,LM) - T(I,J,L3KM(I,J)) - 7.0)
IF((T(I,J,LM) - T(I,J,L3KM(I,J))) < 7.0) ESP(I,J) = 0.
! IF(CAPE(I,J) < 250.) ESP(I,J) = 0.
@@ -1786,5 +1668,969 @@ elemental function TVIRTUAL(T,Q)
end function TVIRTUAL
!
!-------------------------------------------------------------------------------------
+!
+!> @file
+!> @brief Subroutine that computes absolute vorticity.
+!>
+!> This routine computes the absolute vorticity.
+!>
+!> @param[in] UWND U wind (m/s) mass-points.
+!> @param[in] VWND V wind (m/s) mass-points.
+!> @param[out] ABSV absolute vorticity (1/s) mass-points.
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1992-12-22 | Russ Treadon | Initial
+!> 1998-06-08 | T Black | Convesion from 1-D to 2-D
+!> 2000-01-04 | Jim Tuccillo | MPI Version
+!> 2002-01-15 | Mike Baldwin | WRF Version C-grid
+!> 2005-03-01 | H Chuang | Add NMM E grid
+!> 2005-05-17 | H Chuang | Add Potential vorticity calculation
+!> 2005-07-07 | B Zhou | Add RSM in computing DVDX, DUDY and UAVG
+!> 2013-08-09 | S Moorthi | Optimize the vorticity loop including threading
+!> 2016-08-05 | S Moorthi | add zonal filetering
+!> 2019-10-17 | Y Mao | Skip calculation when U/V is SPVAL
+!> 2020-11-06 | J Meng | Use UPP_MATH Module
+!> 2022-05-26 | H Chuang | Use GSL approach for FV3R
+!>
+!> @author Russ Treadon W/NP2 @date 1992-12-22
+ SUBROUTINE CALVOR(UWND,VWND,ABSV)
+
+!
+!
+ use vrbls2d, only: f
+ use masks, only: gdlat, gdlon, dx, dy
+ use params_mod, only: d00, dtr, small, erad
+ use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, &
+ jsta, jend, im, jm, jsta_m, jend_m, gdsdegr,&
+ ista, iend, ista_m, iend_m, ista_2l, iend_2u, me, num_procs
+ use gridspec_mod, only: gridtype, dyval
+ use upp_math, only: DVDXDUDY, DDVDX, DDUDY, UUAVG
+
+ implicit none
+!
+! DECLARE VARIABLES.
+!
+ REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: UWND, VWND
+ REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(inout) :: ABSV
+ REAL, dimension(IM,2) :: GLATPOLES, COSLPOLES, UPOLES, AVPOLES
+ REAL, dimension(IM,JSTA:JEND) :: COSLTEMP, AVTEMP
+!
+ real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), cosl(:,:)
+ INTEGER, allocatable :: IHE(:),IHW(:), IE(:),IW(:)
+!
+ integer, parameter :: npass2=2, npass3=3
+ integer I,J,ip1,im1,ii,iir,iil,jj,JMT2,imb2, npass, nn, jtem
+ real R2DX,R2DY,DVDX,DUDY,UAVG,TPH1,TPHI, tx1(im+2), tx2(im+2)
+!
+!***************************************************************************
+! START CALVOR HERE.
+!
+! LOOP TO COMPUTE ABSOLUTE VORTICITY FROM WINDS.
+!
+ IF(MODELNAME == 'RAPR') then
+!$omp parallel do private(i,j)
+ DO J=JSTA_2L,JEND_2U
+ DO I=ISTA_2L,IEND_2U
+ ABSV(I,J) = D00
+ ENDDO
+ ENDDO
+ else
+!$omp parallel do private(i,j)
+ DO J=JSTA_2L,JEND_2U
+ DO I=ISTA_2L,IEND_2U
+ ABSV(I,J) = SPVAL
+ ENDDO
+ ENDDO
+ endif
+
+! print*,'dyval in CALVOR= ',DYVAL
+
+ CALL EXCH(UWND)
+ CALL EXCH(VWND)
+!
+ IF (MODELNAME == 'GFS' .or. global) THEN
+ CALL EXCH(GDLAT(ISTA_2L,JSTA_2L))
+ CALL EXCH(GDLON(ISTA_2L,JSTA_2L))
+
+ allocate (wrk1(ista:iend,jsta:jend), wrk2(ista:iend,jsta:jend), &
+ & wrk3(ista:iend,jsta:jend), cosl(ista_2l:iend_2u,jsta_2l:jend_2u))
+ allocate(iw(im),ie(im))
+
+ imb2 = im/2
+!$omp parallel do private(i)
+ do i=ista,iend
+ ie(i) = i+1
+ iw(i) = i-1
+ enddo
+! iw(1) = im
+! ie(im) = 1
+
+! if(1>=jsta .and. 1<=jend)then
+! if(cos(gdlat(1,1)*dtr)= SMALL) then
+ wrk1(i,j) = 1.0 / (ERAD*cosl(i,j))
+ else
+ wrk1(i,j) = 0.
+ end if
+ if(i == im .or. i == 1) then
+ wrk2(i,j) = 1.0 / ((360.+GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam
+ else
+ wrk2(i,j) = 1.0 / ((GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam
+ end if
+ enddo
+ enddo
+! CALL EXCH(cosl(1,JSTA_2L))
+ CALL EXCH(cosl)
+
+ call fullpole( cosl(ista_2l:iend_2u,jsta_2l:jend_2u),coslpoles)
+ call fullpole(gdlat(ista_2l:iend_2u,jsta_2l:jend_2u),glatpoles)
+
+ if(me==0 ) print*,'CALVOR ',me,glatpoles(ista,1),glatpoles(ista,2)
+ if(me==num_procs-1) print*,'CALVOR ',me,glatpoles(ista,1),glatpoles(ista,2)
+
+!$omp parallel do private(i,j,ii)
+ DO J=JSTA,JEND
+ if (j == 1) then
+ if(gdlat(ista,j) > 0.) then ! count from north to south
+ do i=ista,iend
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi
+ wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GLATPOLES(ii,1))*DTR) !1/dphi
+ enddo
+ else ! count from south to north
+ do i=ista,iend
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GDLAT(II,J))*DTR) !1/dphi
+ wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GLATPOLES(ii,1))*DTR) !1/dphi
+!
+ enddo
+ end if
+ elseif (j == JM) then
+ if(gdlat(ista,j) < 0.) then ! count from north to south
+ do i=ista,iend
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR)
+ wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GLATPOLES(ii,2))*DTR)
+ enddo
+ else ! count from south to north
+ do i=ista,iend
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GDLAT(II,J))*DTR)
+ wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GLATPOLES(ii,2))*DTR)
+ enddo
+ end if
+ else
+ do i=ista,iend
+ wrk3(i,j) = 1.0 / ((GDLAT(I,J-1)-GDLAT(I,J+1))*DTR) !1/dphi
+ enddo
+ endif
+ enddo
+
+ npass = 0
+
+ jtem = jm / 18 + 1
+
+ call fullpole(uwnd(ista_2l:iend_2u,jsta_2l:jend_2u),upoles)
+
+!$omp parallel do private(i,j,ip1,im1,ii,jj,tx1,tx2)
+ DO J=JSTA,JEND
+! npass = npass2
+! if (j > jm-jtem+1 .or. j < jtem) npass = npass3
+ IF(J == 1) then ! Near North or South pole
+ if(gdlat(ista,j) > 0.) then ! count from north to south
+ IF(cosl(ista,j) >= SMALL) THEN !not a pole point
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. &
+! UWND(II,J)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle
+ UPOLES(II,1)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle
+ ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) &
+! & + (UWND(II,J)*COSL(II,J) &
+ & + (upoles(II,1)*coslpoles(II,1) &
+ & + UWND(I,J+1)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) &
+ & + F(I,J)
+ enddo
+ ELSE !pole point, compute at j=2
+ jj = 2
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. &
+ UWND(I,J)==SPVAL .or. UWND(I,jj+1)==SPVAL) cycle
+ ABSV(I,J) = ((VWND(ip1,JJ)-VWND(im1,JJ))*wrk2(i,jj) &
+ & - (UWND(I,J)*COSL(I,J) &
+ - UWND(I,jj+1)*COSL(I,Jj+1))*wrk3(i,jj)) * wrk1(i,jj) &
+ & + F(I,Jj)
+ enddo
+ ENDIF
+ else
+ IF(cosl(ista,j) >= SMALL) THEN !not a pole point
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. &
+! UWND(II,J)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle
+ UPOLES(II,1)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle
+ ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) &
+! & - (UWND(II,J)*COSL(II,J) &
+ & - (upoles(II,1)*coslpoles(II,1) &
+ & + UWND(I,J+1)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) &
+ & + F(I,J)
+ enddo
+ ELSE !pole point, compute at j=2
+ jj = 2
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. &
+ UWND(I,J)==SPVAL .or. UWND(I,jj+1)==SPVAL) cycle
+ ABSV(I,J) = ((VWND(ip1,JJ)-VWND(im1,JJ))*wrk2(i,jj) &
+ & + (UWND(I,J)*COSL(I,J) &
+ - UWND(I,jj+1)*COSL(I,Jj+1))*wrk3(i,jj)) * wrk1(i,jj) &
+ & + F(I,Jj)
+ enddo
+ ENDIF
+ endif
+ ELSE IF(J == JM) THEN ! Near North or South Pole
+ if(gdlat(ista,j) < 0.) then ! count from north to south
+ IF(cosl(ista,j) >= SMALL) THEN !not a pole point
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. &
+! UWND(I,J-1)==SPVAL .or. UWND(II,J)==SPVAL) cycle
+ UWND(I,J-1)==SPVAL .or. UPOLES(II,2)==SPVAL) cycle
+ ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) &
+ & - (UWND(I,J-1)*COSL(I,J-1) &
+! & + UWND(II,J)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j) &
+ & + upoles(II,2)*coslpoles(II,2))*wrk3(i,j)) * wrk1(i,j) &
+ & + F(I,J)
+ enddo
+ ELSE !pole point,compute at jm-1
+ jj = jm-1
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. &
+ UWND(I,jj-1)==SPVAL .or. UWND(I,J)==SPVAL) cycle
+ ABSV(I,J) = ((VWND(ip1,JJ)-VWND(im1,JJ))*wrk2(i,jj) &
+ & - (UWND(I,jj-1)*COSL(I,Jj-1) &
+ & - UWND(I,J)*COSL(I,J))*wrk3(i,jj)) * wrk1(i,jj) &
+ & + F(I,Jj)
+ enddo
+ ENDIF
+ else
+ IF(cosl(ista,j) >= SMALL) THEN !not a pole point
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. &
+! UWND(I,J-1)==SPVAL .or. UWND(II,J)==SPVAL) cycle
+ UWND(I,J-1)==SPVAL .or. UPOLES(II,2)==SPVAL) cycle
+ ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) &
+ & + (UWND(I,J-1)*COSL(I,J-1) &
+! & + UWND(II,J)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j) &
+ & + upoles(II,2)*coslpoles(II,2))*wrk3(i,j)) * wrk1(i,j) &
+ & + F(I,J)
+ enddo
+ ELSE !pole point,compute at jm-1
+ jj = jm-1
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. &
+ UWND(I,jj-1)==SPVAL .or. UWND(I,J)==SPVAL) cycle
+ ABSV(I,J) = ((VWND(ip1,JJ)-VWND(im1,JJ))*wrk2(i,jj) &
+ & + (UWND(I,jj-1)*COSL(I,Jj-1) &
+ & - UWND(I,J)*COSL(I,J))*wrk3(i,jj)) * wrk1(i,jj) &
+ & + F(I,Jj)
+ enddo
+ ENDIF
+ endif
+ ELSE
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. &
+ UWND(I,J-1)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle
+ ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) &
+ & - (UWND(I,J-1)*COSL(I,J-1) &
+ - UWND(I,J+1)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) &
+ + F(I,J)
+ ENDDO
+ END IF
+! if(ABSV(I,J)>1.0)print*,'Debug CALVOR',i,j,VWND(ip1,J),VWND(im1,J), &
+! wrk2(i,j),UWND(I,J-1),COSL(I,J-1),UWND(I,J+1),COSL(I,J+1),wrk3(i,j),cosl(i,j),F(I,J),ABSV(I,J)
+ if (npass > 0) then
+ do i=ista,iend
+ tx1(i) = absv(i,j)
+ enddo
+ do nn=1,npass
+ do i=ista,iend
+ tx2(i+1) = tx1(i)
+ enddo
+ tx2(1) = tx2(im+1)
+ tx2(im+2) = tx2(2)
+ do i=2,im+1
+ tx1(i-1) = 0.25 * (tx2(i-1) + tx2(i+1)) + 0.5*tx2(i)
+ enddo
+ enddo
+ do i=ista,iend
+ absv(i,j) = tx1(i)
+ enddo
+ endif
+ END DO ! end of J loop
+
+! deallocate (wrk1, wrk2, wrk3, cosl)
+! GFS use lon avg as one scaler value for pole point
+
+ ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1,jsta),SPVAL,ABSV(1,jsta))
+
+ call exch(absv(ista_2l:iend_2u,jsta_2l:jend_2u))
+ call fullpole(absv(ista_2l:iend_2u,jsta_2l:jend_2u),avpoles)
+
+ cosltemp=spval
+ if(jsta== 1) cosltemp(1:im, 1)=coslpoles(1:im,1)
+ if(jend==jm) cosltemp(1:im,jm)=coslpoles(1:im,2)
+ avtemp=spval
+ if(jsta== 1) avtemp(1:im, 1)=avpoles(1:im,1)
+ if(jend==jm) avtemp(1:im,jm)=avpoles(1:im,2)
+
+ call poleavg(IM,JM,JSTA,JEND,SMALL,cosltemp(1,jsta),SPVAL,avtemp(1,jsta))
+
+ if(jsta== 1) absv(ista:iend, 1)=avtemp(ista:iend, 1)
+ if(jend==jm) absv(ista:iend,jm)=avtemp(ista:iend,jm)
+
+ deallocate (wrk1, wrk2, wrk3, cosl, iw, ie)
+
+ ELSE !(MODELNAME == 'GFS' .or. global)
+
+ IF (GRIDTYPE == 'B')THEN
+ CALL EXCH(VWND)
+ CALL EXCH(UWND)
+ ENDIF
+
+ CALL DVDXDUDY(UWND,VWND)
+
+ IF(GRIDTYPE == 'A')THEN
+!$omp parallel do private(i,j,jmt2,tphi,r2dx,r2dy,dvdx,dudy,uavg)
+ DO J=JSTA_M,JEND_M
+ JMT2 = JM/2+1
+ TPHI = (J-JMT2)*(DYVAL/gdsdegr)*DTR
+ DO I=ISTA_M,IEND_M
+ IF(DDVDX(I,J) CALDIV computes divergence.
+!>
+!> For GFS, this routine copmutes the horizontal divergence
+!> using 2nd-order centered scheme on a lat-lon grid
+!>
+!> @param[in] UWND U wind (m/s) mass-points.
+!> @param[in] VWND V wind (m/s) mass-points.
+!> @param[out] DIV divergence (1/s) mass-points.
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2016-05-05 | Sajal Kar | Modified CALVORT to compute divergence from wind components
+!> 2016-07-22 | S Moorthi | Modified polar divergence calculation
+!>
+!> @author Sajal Kar W/NP2 @date 2016-05-05
+ SUBROUTINE CALDIV(UWND,VWND,DIV)
+ use masks, only: gdlat, gdlon
+ use params_mod, only: d00, dtr, small, erad
+ use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, &
+ jsta, jend, im, jm, jsta_m, jend_m, lm, &
+ ista, iend, ista_m, iend_m, ista_2l, iend_2u
+ use gridspec_mod, only: gridtype
+
+ implicit none
+!
+! DECLARE VARIABLES.
+!
+ REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm), intent(in) :: UWND,VWND
+ REAL, dimension(ista:iend,jsta:jend,lm), intent(inout) :: DIV
+ REAL, dimension(IM,2) :: GLATPOLES, COSLPOLES, UPOLES, VPOLES, DIVPOLES
+ REAL, dimension(IM,JSTA:JEND) :: COSLTEMP, DIVTEMP
+!
+ real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), cosl(:,:)
+ INTEGER, allocatable :: IHE(:),IHW(:), IE(:),IW(:)
+!
+ real :: dnpole, dspole, tem
+ integer I,J,ip1,im1,ii,iir,iil,jj,imb2, l
+!
+!***************************************************************************
+! START CALDIV HERE.
+!
+! LOOP TO COMPUTE DIVERGENCE FROM WINDS.
+!
+ CALL EXCH(GDLAT(ISTA_2L,JSTA_2L))
+ CALL EXCH(GDLON(ISTA_2L,JSTA_2L))
+
+ allocate (wrk1(ista:iend,jsta:jend), wrk2(ista:iend,jsta:jend), &
+ & wrk3(ista:iend,jsta:jend), cosl(ista_2l:iend_2u,jsta_2l:jend_2u))
+ allocate(iw(im),ie(im))
+
+ imb2 = im/2
+!$omp parallel do private(i)
+ do i=ista,iend
+ ie(i) = i+1
+ iw(i) = i-1
+ enddo
+! iw(1) = im
+! ie(im) = 1
+
+
+!$omp parallel do private(i,j,ip1,im1)
+ DO J=JSTA,JEND
+ do i=ista,iend
+ ip1 = ie(i)
+ im1 = iw(i)
+ cosl(i,j) = cos(gdlat(i,j)*dtr)
+ IF(cosl(i,j) >= SMALL) then
+ wrk1(i,j) = 1.0 / (ERAD*cosl(i,j))
+ else
+ wrk1(i,j) = 0.
+ end if
+ if(i == im .or. i == 1) then
+ wrk2(i,j) = 1.0 / ((360.+GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam
+ else
+ wrk2(i,j) = 1.0 / ((GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam
+ end if
+ enddo
+ ENDDO
+
+ CALL EXCH(cosl)
+ CALL FULLPOLE(cosl,coslpoles)
+ CALL FULLPOLE(gdlat(ista_2l:iend_2u,jsta_2l:jend_2u),glatpoles)
+
+!$omp parallel do private(i,j,ii)
+ DO J=JSTA,JEND
+ if (j == 1) then
+ if(gdlat(ista,j) > 0.) then ! count from north to south
+ do i=ista,iend
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi
+ wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GLATPOLES(II,1))*DTR) !1/dphi
+ enddo
+ else ! count from south to north
+ do i=ista,iend
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GDLAT(II,J))*DTR) !1/dphi
+ wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GLATPOLES(II,1))*DTR) !1/dphi
+ enddo
+ end if
+ elseif (j == JM) then
+ if(gdlat(ista,j) < 0.) then ! count from north to south
+ do i=ista,iend
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR)
+ wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GLATPOLES(II,2))*DTR)
+ enddo
+ else ! count from south to north
+ do i=ista,iend
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GDLAT(II,J))*DTR)
+ wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GLATPOLES(II,2))*DTR)
+ enddo
+ end if
+ else
+ do i=ista,iend
+ wrk3(i,j) = 1.0 / ((GDLAT(I,J-1)-GDLAT(I,J+1))*DTR) !1/dphi
+ enddo
+ endif
+ enddo
+
+ do l=1,lm
+!$omp parallel do private(i,j)
+ DO J=JSTA,JEND
+ DO I=ISTA,IEND
+ DIV(I,J,l) = SPVAL
+ ENDDO
+ ENDDO
+
+ CALL EXCH(VWND(ista_2l,jsta_2l,l))
+ CALL EXCH(UWND(ista_2l,jsta_2l,l))
+
+ CALL FULLPOLE(VWND(ista_2l:iend_2u,jsta_2l:jend_2u,l),VPOLES)
+ CALL FULLPOLE(UWND(ista_2l:iend_2u,jsta_2l:jend_2u,l),UPOLES)
+
+!$omp parallel do private(i,j,ip1,im1,ii,jj)
+ DO J=JSTA,JEND
+ IF(J == 1) then ! Near North pole
+ if(gdlat(ista,j) > 0.) then ! count from north to south
+ IF(cosl(ista,j) >= SMALL) THEN !not a pole point
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) &
+ !& ! - (VWND(II,J,l)*COSL(II,J) &
+ & - (VPOLES(II,1)*COSLPOLEs(II,1) &
+ & + VWND(I,J+1,l)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j)
+ enddo
+!--
+ ELSE !North pole point, compute at j=2
+ jj = 2
+ do i=ista,iend
+ ip1 = ie(i)
+ im1 = iw(i)
+ DIV(I,J,l) = ((UWND(ip1,jj,l)-UWND(im1,jj,l))*wrk2(i,jj) &
+ & + (VWND(I,J,l)*COSL(I,J) &
+ - VWND(I,jj+1,l)*COSL(I,jj+1))*wrk3(i,jj)) * wrk1(i,jj)
+ enddo
+!--
+ ENDIF
+ else
+ IF(cosl(ista,j) >= SMALL) THEN !not a pole point
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) &
+ !& ! + (VWND(II,J,l)*COSL(II,J) &
+ & + (VPOLES(II,1)*COSLPOLES(II,1) &
+ & + VWND(I,J+1,l)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j)
+ enddo
+!--
+ ELSE !North pole point, compute at j=2
+ jj = 2
+ do i=ista,iend
+ ip1 = ie(i)
+ im1 = iw(i)
+ DIV(I,J,l) = ((UWND(ip1,jj,l)-UWND(im1,jj,l))*wrk2(i,jj) &
+ & - (VWND(I,J,l)*COSL(I,J) &
+ - VWND(I,jj+1,l)*COSL(I,jj+1))*wrk3(i,jj)) * wrk1(i,jj)
+ enddo
+ ENDIF
+ endif
+ ELSE IF(J == JM) THEN ! Near South pole
+ if(gdlat(ista,j) < 0.) then ! count from north to south
+ IF(cosl(ista,j) >= SMALL) THEN !not a pole point
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) &
+ & + (VWND(I,J-1,l)*COSL(I,J-1) &
+ !& ! + VWND(II,J,l)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j)
+ & + VPOLES(II,2)*COSLPOLES(II,2))*wrk3(i,j)) * wrk1(i,j)
+ enddo
+!--
+ ELSE !South pole point,compute at jm-1
+ jj = jm-1
+ do i=ista,iend
+ ip1 = ie(i)
+ im1 = iw(i)
+ DIV(I,J,l) = ((UWND(ip1,JJ,l)-UWND(im1,JJ,l))*wrk2(i,jj) &
+ & + (VWND(I,jj-1,l)*COSL(I,Jj-1) &
+ & - VWND(I,J,l)*COSL(I,J))*wrk3(i,jj)) * wrk1(i,jj)
+
+ enddo
+ ENDIF
+ else
+ IF(cosl(ista,j) >= SMALL) THEN !not a pole point
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) &
+ & - (VWND(I,J-1,l)*COSL(I,J-1) &
+ !& ! + VWND(II,J,l)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j)
+ & + VPOLES(II,2)*COSLPOLES(II,2))*wrk3(i,j)) * wrk1(i,j)
+ enddo
+!--
+ ELSE !South pole point,compute at jm-1
+ jj = jm-1
+ do i=ista,iend
+ ip1 = ie(i)
+ im1 = iw(i)
+ DIV(I,J,l) = ((UWND(ip1,JJ,l)-UWND(im1,JJ,l))*wrk2(i,jj) &
+ & - (VWND(I,jj-1,l)*COSL(I,Jj-1) &
+ & - VWND(I,J,l)*COSL(I,J))*wrk3(i,jj)) * wrk1(i,jj)
+
+ enddo
+ ENDIF
+ endif
+ ELSE
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) &
+ & + (VWND(I,J-1,l)*COSL(I,J-1) &
+ - VWND(I,J+1,l)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j)
+!sk06132016
+ if(DIV(I,J,l)>1.0)print*,'Debug in CALDIV',i,j,UWND(ip1,J,l),UWND(im1,J,l), &
+ & wrk2(i,j),VWND(I,J-1,l),COSL(I,J-1),VWND(I,J+1,l),COSL(I,J+1), &
+ & wrk3(i,j),wrk1(i,j),DIV(I,J,l)
+!--
+ ENDDO
+ ENDIF
+ ENDDO ! end of J loop
+
+! GFS use lon avg as one scaler value for pole point
+! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1,jsta),SPVAL,DIV(1,jsta,l))
+
+ call exch(div(ista_2l:iend_2u,jsta_2l:jend_2u,l))
+ call fullpole(div(ista_2l:iend_2u,jsta_2l:jend_2u,l),divpoles)
+
+ COSLTEMP=SPVAL
+ IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1)
+ IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2)
+ DIVTEMP=SPVAL
+ IF(JSTA== 1) DIVTEMP(1:IM, 1)=DIVPOLES(1:IM,1)
+ IF(JEND==JM) DIVTEMP(1:IM,JM)=DIVPOLES(1:IM,2)
+
+ call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) &
+ ,SPVAL,DIVTEMP(1:IM,JSTA:JEND))
+
+ IF(JSTA== 1) DIV(ISTA:IEND, 1,L)=DIVTEMP(ISTA:IEND, 1)
+ IF(JEND==JM) DIV(ISTA:IEND,JM,L)=DIVTEMP(ISTA:IEND,JM)
+
+!sk06142016e
+ if(DIV(ista,jsta,l)>1.0)print*,'Debug in CALDIV',jsta,DIV(ista,jsta,l)
+! print*,'Debug in CALDIV',' jsta= ',jsta,DIV(1,jsta,l)
+
+ enddo ! end of l looop
+!--
+ deallocate (wrk1, wrk2, wrk3, cosl, iw, ie)
+
+
+ END SUBROUTINE CALDIV
+
+ SUBROUTINE CALGRADPS(PS,PSX,PSY)
+!> CALGRADPS computes gardients of a scalar field PS or LNPS.
+!>
+!> For GFS, this routine computes horizontal gradients of PS or LNPS.
+!> Using 2nd-order centered scheme on a lat-lon grid.
+!>
+!> @param[in] PS Surface pressure (Pa) mass-points.
+!> @param[out] PSX Zonal gradient of PS at mass-points.
+!> @param[out] PSY Meridional gradient of PS at mass-points.
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2016-05-05 | Sajal Kar | Reduced from CALVORT to zonal and meridional gradients of given surface pressure PS, or LNPS
+!>
+!> @author Sajal Kar W/NP2 @date 2016-05-05
+ use masks, only: gdlat, gdlon
+ use params_mod, only: dtr, d00, small, erad
+ use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, &
+ jsta, jend, im, jm, jsta_m, jend_m, &
+ ista, iend, ista_m, iend_m, ista_2l, iend_2u
+
+ use gridspec_mod, only: gridtype
+
+ implicit none
+!
+! DECLARE VARIABLES.
+!
+ REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: PS
+ REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(inout) :: PSX,PSY
+!
+ real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), cosl(:,:)
+ INTEGER, allocatable :: IHE(:),IHW(:), IE(:),IW(:)
+!
+ integer I,J,ip1,im1,ii,iir,iil,jj,imb2
+!
+!***************************************************************************
+! START CALGRADPS HERE.
+!
+! LOOP TO COMPUTE ZONAL AND MERIDIONAL GRADIENTS OF PS OR LNPS
+!
+!sk06162016 DO J=JSTA_2L,JEND_2U
+!$omp parallel do private(i,j)
+ DO J=JSTA,JEND
+ DO I=ISTA,IEND
+ PSX(I,J) = SPVAL
+ PSY(I,J) = SPVAL
+!sk PSX(I,J) = D00
+!sk PSY(I,J) = D00
+ ENDDO
+ ENDDO
+
+ CALL EXCH(PS)
+
+! IF (MODELNAME == 'GFS' .or. global) THEN
+ CALL EXCH(GDLAT(ISTA_2L,JSTA_2L))
+ CALL EXCH(GDLON(ISTA_2L,JSTA_2L))
+
+ allocate (wrk1(ista:iend,jsta:jend), wrk2(ista:iend,jsta:jend), &
+ & wrk3(ista:iend,jsta:jend), cosl(ista_2l:iend_2u,jsta_2l:jend_2u))
+ allocate(iw(im),ie(im))
+
+ imb2 = im/2
+!$omp parallel do private(i)
+ do i=ista,iend
+ ie(i) = i+1
+ iw(i) = i-1
+ enddo
+! iw(1) = im
+! ie(im) = 1
+
+
+!$omp parallel do private(i,j,ip1,im1)
+ DO J=JSTA,JEND
+ do i=ista,iend
+ ip1 = ie(i)
+ im1 = iw(i)
+ cosl(i,j) = cos(gdlat(i,j)*dtr)
+ if(cosl(i,j) >= SMALL) then
+ wrk1(i,j) = 1.0 / (ERAD*cosl(i,j))
+ else
+ wrk1(i,j) = 0.
+ end if
+ if(i == im .or. i == 1) then
+ wrk2(i,j) = 1.0 / ((360.+GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam
+ else
+ wrk2(i,j) = 1.0 / ((GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam
+ end if
+ enddo
+ ENDDO
+
+ CALL EXCH(cosl)
+
+!$omp parallel do private(i,j,ii)
+ DO J=JSTA,JEND
+ if (j == 1) then
+ if(gdlat(ista,j) > 0.) then ! count from north to south
+ do i=ista,iend
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi
+ enddo
+ else ! count from south to north
+ do i=ista,iend
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GDLAT(II,J))*DTR) !1/dphi
+ enddo
+ end if
+ elseif (j == JM) then
+ if(gdlat(ista,j) < 0.) then ! count from north to south
+ do i=ista,iend
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR)
+ enddo
+ else ! count from south to north
+ do i=ista,iend
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GDLAT(II,J))*DTR)
+ enddo
+ end if
+ else
+ do i=ista,iend
+ wrk3(i,j) = 1.0 / ((GDLAT(I,J-1)-GDLAT(I,J+1))*DTR) !1/dphi
+ enddo
+ endif
+ ENDDO
+
+!$omp parallel do private(i,j,ip1,im1,ii,jj)
+ DO J=JSTA,JEND
+ IF(J == 1) then ! Near North pole
+ if(gdlat(ista,j) > 0.) then ! count from north to south
+ IF(cosl(ista,j) >= SMALL) THEN !not a pole point
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j)
+ PSY(I,J) = (PS(II,J)-PS(I,J+1))*wrk3(i,j)/ERAD
+ enddo
+ ELSE !North pole point, compute at j=2
+ jj = 2
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ PSX(I,J) = (PS(ip1,jj)-PS(im1,jj))*wrk2(i,jj)*wrk1(i,jj)
+ PSY(I,J) = (PS(I,J)-PS(I,jj+1))*wrk3(i,jj)/ERAD
+ enddo
+ ENDIF
+ else
+ IF(cosl(ista,j) >= SMALL) THEN !not a pole point
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j)
+ PSY(I,J) = - (PS(II,J)-PS(I,J+1))*wrk3(i,j)/ERAD
+ enddo
+ ELSE !North pole point, compute at j=2
+ jj = 2
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ PSX(I,J) = (PS(ip1,jj)-PS(im1,jj))*wrk2(i,jj)*wrk1(i,jj)
+ PSY(I,J) = - (PS(I,J)-PS(I,jj+1))*wrk3(i,jj)/ERAD
+ enddo
+ ENDIF
+ endif
+ ELSE IF(J == JM) THEN ! Near South pole
+ if(gdlat(ista,j) < 0.) then ! count from north to south
+ IF(cosl(ista,j) >= SMALL) THEN !not a pole point
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j)
+ PSY(I,J) = (PS(I,J-1)-PS(II,J))*wrk3(i,j)/ERAD
+ enddo
+ ELSE !South pole point,compute at jm-1
+ jj = jm-1
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ PSX(I,J) = (PS(ip1,JJ)-PS(im1,JJ))*wrk2(i,jj)*wrk1(i,jj)
+ PSY(I,J) = (PS(I,jj-1)-PS(I,J))*wrk3(i,jj)/ERAD
+ enddo
+ ENDIF
+ else
+ IF(cosl(ista,j) >= SMALL) THEN !not a pole point
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ ii = i + imb2
+ if (ii > im) ii = ii - im
+ PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j)
+ PSY(I,J) = - (PS(I,J-1)-PS(II,J))*wrk3(i,j)/ERAD
+ enddo
+ ELSE !South pole point,compute at jm-1
+ jj = jm-1
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ PSX(I,J) = (PS(ip1,JJ)-PS(im1,JJ))*wrk2(i,jj)*wrk1(i,jj)
+ PSY(I,J) = - (PS(I,jj-1)-PS(I,J))*wrk3(i,jj)/ERAD
+ enddo
+ ENDIF
+ endif
+ ELSE
+ DO I=ISTA,IEND
+ ip1 = ie(i)
+ im1 = iw(i)
+ PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j)
+ PSY(I,J) = (PS(I,J-1)-PS(I,J+1))*wrk3(i,j)/ERAD
+!sk06142016A
+ if(PSX(I,J)>100.0)print*,'Debug in CALGRADPS: PSX',i,j,PS(ip1,J),PS(im1,J), &
+! print*,'Debug in CALGRADPS',i,j,PS(ip1,J),PS(im1,J), &
+ & wrk2(i,j),wrk1(i,j),PSX(I,J)
+ if(PSY(I,J)>100.0)print*,'Debug in CALGRADPS: PSY',i,j,PS(i,J-1),PS(i,J+1), &
+! print*,'Debug in CALGRADPS',i,j,PS(i,J-1),PS(i,J+1), &
+ & wrk3(i,j),ERAD,PSY(I,J)
+!--
+ ENDDO
+ END IF
+!
+ ENDDO ! end of J loop
+
+ deallocate (wrk1, wrk2, wrk3, cosl, iw, ie)
+
+! END IF
+
+ END SUBROUTINE CALGRADPS
+!
+!-------------------------------------------------------------------------------------
!
end module upp_physics
+
diff --git a/sorc/ncep_post.fd/VRBLS2D_mod.f b/sorc/ncep_post.fd/VRBLS2D_mod.f
index aa3231177..569f34ea5 100644
--- a/sorc/ncep_post.fd/VRBLS2D_mod.f
+++ b/sorc/ncep_post.fd/VRBLS2D_mod.f
@@ -82,7 +82,7 @@ module vrbls2d
,avgesnow(:,:),avgpotevp(:,:),avgprec_cont(:,:),avgcprate_cont(:,:)&
,ti(:,:),aod550(:,:),du_aod550(:,:),ss_aod550(:,:),su_aod550(:,:) &
,bc_aod550(:,:),oc_aod550(:,:),landfrac(:,:),paha(:,:),pahi(:,:) &
- ,tecan(:,:),tetran(:,:),tedir(:,:),twa(:,:),fdnsst(:,:)
+ ,tecan(:,:),tetran(:,:),tedir(:,:),twa(:,:),fdnsst(:,:),pwat(:,:)
integer, allocatable :: IVGTYP(:,:),ISLTYP(:,:),ISLOPE(:,:) &
,IEQL(:,:)
@@ -95,7 +95,7 @@ module vrbls2d
,SSSMASS(:,:),SSCMASS(:,:),SSSMASS25(:,:),SSCMASS25(:,:) &
,DUSTCB(:,:),SSCB(:,:),OCCB(:,:),BCCB(:,:),SULFCB(:,:) &
,DUSTALLCB(:,:),SSALLCB(:,:),DUSTPM(:,:),SSPM(:,:),PP25CB(:,:) &
- ,PP10CB(:,:)!lzhang, add for FV3-Chem
+ ,DUSTPM10(:,:),PP10CB(:,:),maod(:,:)!lzhang, add for FV3-Chem
!
end module vrbls2d
diff --git a/sorc/ncep_post.fd/WETBULB.f b/sorc/ncep_post.fd/WETBULB.f
index f22ba0368..f63b9c73b 100644
--- a/sorc/ncep_post.fd/WETBULB.f
+++ b/sorc/ncep_post.fd/WETBULB.f
@@ -8,6 +8,7 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET)
! MODIFIED FOR HYBRID: OCT 2001, H CHUANG
! 02-01-15 MIKE BALDWIN - WRF VERSION
! 21-07-26 Wen Meng - Restrict compuation from undefined grids
+! 21-09-13 Jesse Meng- 2D DECOMPOSITION
!
!-----------------------------------------------------------------------
! ROUTINE TO COMPUTE WET BULB TEMPERATURES USING THE LOOK UP TABLE
@@ -23,7 +24,8 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET)
use lookup_mod, only: thl, rdth, jtb, qs0, sqs, rdq, itb, ptbl, plq, ttbl,&
pl, rdp, the0, sthe, rdthe, ttblq, itbq, jtbq, rdpq, the0q, stheq,&
rdtheq
- use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, lm, spval
+ use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, lm, spval, &
+ ista, iend, ista_2l, iend_2u
use cuparm_mod, only: h10e5, capa, epsq, d00, elocp
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
@@ -39,14 +41,14 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET)
! SUBROUTINES CALLED:
! TTBLEX
!
- real,dimension(IM,jsta_2l:jend_2u,LM),intent(in) :: T,Q, &
+ real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,LM),intent(in) :: T,Q, &
PMID,HTM
- integer,dimension(IM,jsta:jend), intent(in) :: KARR
- real,dimension(IM,jsta_2l:jend_2u,LM),intent(out) :: TWET
+ integer,dimension(ista:iend,jsta:jend), intent(in) :: KARR
+ real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,LM),intent(out) :: TWET
- real, dimension(im,jsta:jend) :: THESP, QQ, PP
- integer, dimension(im,jsta:jend) :: KLRES,KHRES,IPTB,ITHTB
+ real, dimension(ista:iend,jsta:jend) :: THESP, QQ, PP
+ integer, dimension(ista:iend,jsta:jend) :: KLRES,KHRES,IPTB,ITHTB
!
integer I,J,L,ITTB1,ITTBK,IQTBK,IT,KNUML,KNUMH,IQ
real TBTK,QBTK,APEBTK,TTHBTK,TTHK,QQK,BQS00K,SQS00K,BQS10K, &
@@ -62,7 +64,7 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET)
!-----------------------------------------------------------------------
DO 300 L=1,LM
DO 125 J=JSTA,JEND
- DO 125 I=1,IM
+ DO 125 I=ISTA,IEND
IF (HTM(I,J,L)<1.0) THEN
THESP(I,J)=273.15
cycle
@@ -132,7 +134,7 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET)
KNUMH=0
!
DO 280 J=JSTA,JEND
- DO 280 I=1,IM
+ DO 280 I=ISTA,IEND
KLRES(I,J)=0
KHRES(I,J)=0
!
@@ -153,16 +155,16 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET)
!*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE0)THEN
- CALL TTBLEX(TWET(1,jsta_2l,L),TTBL,ITB,JTB,KLRES &
- ,PMID(1,jsta_2l,L),PL,QQ,PP,RDP,THE0,STHE &
+ CALL TTBLEX(TWET(ista_2l,jsta_2l,L),TTBL,ITB,JTB,KLRES &
+ ,PMID(ista_2l,jsta_2l,L),PL,QQ,PP,RDP,THE0,STHE &
,RDTHE,THESP,IPTB,ITHTB)
ENDIF
!***
!*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PL
!**
IF(KNUMH>0)THEN
- CALL TTBLEX(TWET(1,jsta_2l,L),TTBLQ,ITBQ,JTBQ,KHRES &
- ,PMID(1,jsta_2l,L),PLQ,QQ,PP,RDPQ,THE0Q,STHEQ &
+ CALL TTBLEX(TWET(ista_2l,jsta_2l,L),TTBLQ,ITBQ,JTBQ,KHRES &
+ ,PMID(ista_2l,jsta_2l,L),PLQ,QQ,PP,RDPQ,THE0Q,STHEQ &
,RDTHEQ,THESP,IPTB,ITHTB)
ENDIF
!-----------------------------------------------------------------------
diff --git a/sorc/ncep_post.fd/WETFRZLVL.f b/sorc/ncep_post.fd/WETFRZLVL.f
index a3aeeede5..63aa39c9e 100644
--- a/sorc/ncep_post.fd/WETFRZLVL.f
+++ b/sorc/ncep_post.fd/WETFRZLVL.f
@@ -1,52 +1,33 @@
!> @file
-! . . .
-!> SUBPROGRAM: WETFRZLVL COMPUTES LEVEL OF 0 WET BULB
-!! PRGRMMR: MANIKIN ORG: W/NP2 DATE: 03-11-14
-!!
-!! ABSTRACT:
-!! THIS ROUTINE COMPUTES THE LOWEST HEIGHT WITH A WET BULB
-!! TEMPERATURE OF FREEZING FOR EACH MASS POINT ON THE ETA GRID.
-!! THE COMPUTED WET BULB ZERO HEIGHT IS THE MEAN SEA LEVEL
-!! HEIGHT. AT EACH MASS POINT WE MOVE UP FROM THE SURFACE TO
-!! FIND THE FIRST ETA LAYER WHERE THE TW IS LESS THAN
-!! 273.16K. VERTICAL INTERPOLATION IN TEMPERATURE TO THE FREEZING
-!! TEMPERATURE GIVES THE FREEZING LEVEL HEIGHT. PRESSURE AND
-!! SPECIFIC HUMIDITY ARE INTERPOLATED TO THIS LEVEL AND ALONG WITH
-!! THE TEMPERATURE PROVIDE THE FREEZING LEVEL RELATIVE HUMIDITY.
-!! IF THE SURFACE (SKIN) TEMPERATURE IS BELOW FREEZING, THE ROUTINE
-!! USES SURFACE BASED FIELDS TO COMPUTE THE RELATIVE HUMIDITY.
-!!
-!! PROGRAM HISTORY LOG:
-!! 03-11-14 GEOFF MANIKIN - NEW PROGRAM
-!! 04-12-06 G MANIKIN - CORRECTED COMPUTATION OF SFC TEMPERATURE
-!! 05-03-11 H CHUANG - WRF VERSION
-!! 21-07-26 W Meng - Restrict computation from undefined grids
-!!
-!! USAGE: CALL WETFRZLVL(TWET,ZWET)
-!! INPUT ARGUMENT LIST:
-!! TWET - WET BULB TEMPERATURES
-!!
-!! OUTPUT ARGUMENT LIST:
-!! ZWET - ABOVE GROUND LEVEL HEIGHT OF LEVEL WITH 0 WET BULB.
-!!
-!! OUTPUT FILES:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! REL_HUM
-!! LIBRARY:
-!! COMMON -
-!! LOOPS
-!! PVRBLS
-!! MASKS
-!! MAPOT
-!! POSTVAR
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN
-!! MACHINE : CRAY C-90
-!!
+!> @brief wetfrzlvl() computes level of 0 wet bulb.
+!>
+!> @author Geoff Manikin W/NP2 @date 2003-11-14
+
+!> This routine computes the lowest height with a wet bulb
+!> temperature of freezing for each mass point on the eta grid.
+!> The computed wet bulb zero height is the mean sea level
+!> height. At each mass point we move up from the surface to
+!> find the first eta layer where the tw is less than
+!> 273.16K. Vertical interpolation in temperature to the freezing
+!> temperature gives the freezing level height. Pressure and
+!> specific humidity are interpolated to this level and along with
+!> the temperature provide the freezing level relative humidity.
+!> If the surface (skin) temperature is below freezing, the routine
+!> uses surface based fields to compute the relative humidity.
+!>
+!> @param[in] TWET Wet bulb temperatures.
+!> @param[out] ZWET Above ground level height of level with 0 wet bulb.
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2003-11-14 | Geoff Manikin | Initial
+!> 2004-12-06 | Geoff Manikin | Corrected computation of SFC temperature
+!> 2005-03-11 | H CHUANG | WRF Version
+!> 2021-07-26 | W Meng | Restrict computation from undefined grids
+!> 2021-09-13 | J Meng | 2D DECOMPOSITION
+!>
+!> @author Geoff Manikin W/NP2 @date 2003-11-14
SUBROUTINE WETFRZLVL(TWET,ZWET)
!
@@ -55,14 +36,15 @@ SUBROUTINE WETFRZLVL(TWET,ZWET)
use vrbls2d, only: fis, thz0, ths
use masks, only: lmh, sm
use params_mod, only: gi, p1000, capa, tfrz, d0065, d50
- use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, lm, spval
+ use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, lm, spval, &
+ ista, iend, ista_2l, iend_2u
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
!
! DECLARE VARIABLES.
!
- REAL,intent(in) :: TWET(IM,JSTA_2L:JEND_2U,LM)
- REAL,intent(out) :: ZWET(IM,jsta:jend)
+ REAL,intent(in) :: TWET(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM)
+ REAL,intent(out) :: ZWET(ista:iend,jsta:jend)
!
integer I,J,LLMH,L
real HTSFC,THSFC,PSFC,TSFC,DELZ,DELT,ZL,ZU
@@ -75,7 +57,7 @@ SUBROUTINE WETFRZLVL(TWET,ZWET)
!!$omp& private(delt,delz,htsfc,l,llmh
!!$omp& tsfc,zl,zu)
DO J=JSTA,JEND
- DO I=1,IM
+ DO I=ISTA,IEND
IF(FIS(I,J)==spval)THEN
ZWET(I,J)=spval
CYCLE
diff --git a/sorc/ncep_post.fd/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f
index 571174dd7..c670150f9 100644
--- a/sorc/ncep_post.fd/WRFPOST.f
+++ b/sorc/ncep_post.fd/WRFPOST.f
@@ -1,68 +1,35 @@
!> @file
-! . . .
-!> MAIN PROGRAM: WRFPOST
-!! PRGMMR: BALDWIN ORG: NSSL/SPC DATE: 2002-06-18
-!!
-!! ABSTRACT:
-!! THIS PROGRAM DRIVES THE EXTERNAL WRF POST PROCESSOR.
-!!
-!! PROGRAM HISTORY LOG:
-!! 92-12-24 RUSS TREADON - CODED ETAPOST AS STAND ALONE CODE
-!! 98-05-29 BLACK - CONVERSION OF POST CODE FROM 1-D TO 2-D
-!! 00-02-04 JIM TUCCILLO - PARALLEL VERSION VIA MPI
-!! 01-02-15 JIM TUCCILLO - MANY COMMON BLOCKS REPLACED WITH MODULES
-!! TO SUPPORT FORTRAN "ALLOCATE"s FOR THE EXACT SIZE OF THE
-!! ARRAYS NEEDED BASED ON THE NUMBER OF MPI TASKS.
-!! THIS WAS DONE TO REDUCE THE ADDRESS SPACE THAT THE LOADER SEES.
-!! THESE CHANGES WERE NECESSARY FOR RUNNING LARGER DOMAINS SUCH AS
-!! 12 KMS
-!! 01-06-15 JIM TUCCILLO - ADDED ASYNCRONOUS I/O CAPABILITY. IF THERE ARE MORE
-!! THAN ONE MPI TASK, THE IO WILL BE DONE AYNCHRONOUSLY BY THE LAST
-!! MPI TASK.
-!! 02-06-17 MIKE BALDWIN - CONVERT ETAPOST TO WRFPOST. INCLUDE WRF I/O API
-!! FOR INPUT OF MODEL DATA. MODIFY CODE TO DEAL WITH C-GRID
-!! DATA. STREAMLINE OUTPUT TO A CALL OF ONE SUBROUTINE INSTEAD OF THREE.
-!! REPLACE COMMON BLOCKS WITH A LIMITED NUMBER OF MODULES.
-!! 04-01-01 H CHUANG - ADDED NMM IO MODULE AND BINARY OPTIONS
-!! 05-07-08 Binbin Zhou: Aadded RSM model
-!! 05-12-05 H CHUANG - ADDED CAPABILITY TO OUTPUT OFF-HOUR FORECAST WHICH HAS
-!! NO IMPACTS ON ON-HOUR FORECAST
-!! 06-02-20 CHUANG, BLACK, AND ROGERS - FINALIZED COMPLETE LIST OF NAM
-!! OPERATIONAL PRODUCTS FROM WRF
-!! 06-02-27 H CHUANG - MODIFIED TO POST MULTIPLE
-!! FORECAST HOURS IN ONE EXECUTION
-!! 06-03-03 H CHUANG - ADDED PARRISH'S MPI BINARY IO TO READ BINARY
-!! WRF FILE AS RANDOM ASSCESS SO THAT VARIABLES IN WRF OUTPUT
-!! DON'T HAVE TO BE READ IN IN SPECIFIC ORDER
-!! 11-02-06 J WANG - ADD GRIB2 OPTION
-!! 11-12-14 SARAH LU - ADD THE OPTION TO READ NGAC AER FILE
-!! 12-01-28 J WANG - Use post available fields in xml file for grib2
-!! 13-06-25 S MOORTHI - add gocart_on logical option to save memory
-!! 13-10-03 J WANG - add option for po to be pascal, and
-!! add gocart_on,d3d_on and popascal to namelist
-!! 20-03-25 J MENG - remove grib1
-!! 21-06-20 W Meng - remove reading grib1 and gfsio lib
-!! 21-10-22 KaYee Wong - created formal fortran namelist for itag
-!! 21-11-03 Tracy Hertneky - Removed SIGIO option
-!!
-!! USAGE: WRFPOST
-!! INPUT ARGUMENT LIST:
-!! NONE
-!!
-!! OUTPUT ARGUMENT LIST:
-!! NONE
-!!
-!! SUBPROGRAMS CALLED:
-!! UTILITIES:
-!! NONE
-!! LIBRARY:
-!! COMMON - CTLBLK
-!! RQSTFLD
-!!
-!! ATTRIBUTES:
-!! LANGUAGE: FORTRAN 90
-!! MACHINE : IBM RS/6000 SP
-!!
+!> @brief wrfpost() drives the external wrf post processor.
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 1992-12-24 | Russ Treadon | Coded etapost as stand alone code
+!> 1998-05-29 | Black | Conversion of post code from 1-D to 2-D
+!> 1900-02-04 | Jim Tuccillo | Parallel version via MPI
+!> 2001-02-15 | Jim Tuccillo | Many common blocks replaced with modules to support fortran "allocate"s for the exact size of the arrays needed based on the number of mpi tasks. This was done to reduce the address space that the loader sees. These changes were necessary for running larger domains such as 12 kms
+!> 2001-06-15 | JIM Tuccillo | Added asyncronous I/O capability. if there are more than one mpi task, the io will be done aynchronously by the last MPI task.
+!> 2002-06-17 | Mike Baldwin | Convert etapost to wrfpost. Include wrf I/O api for input of model data. Modify code to deal with C-grid data. Streamline output to a call of one subroutine instead of three. Replace common blocks with a limited number of modules.
+!> 2004-01-01 | H Chuang | Added nmm io module and binary options
+!> 2005-07-08 | Binbin Zhou | Added RSM model
+!> 2005-12-05 | H Chuang | Added capability to output off-hour forecast which has no impacts on on-hour forecast
+!> 2006-02-20 | Chuang, Black, and Rogers | Finalized complete list of NAM operational products from WRF
+!> 2006-02-27 | H Chuang | Modified to post multiple forecast hours in one execution
+!> 2006-03-03 | H Chuang | Added parrish's mpi binary io to read binary WRF file as random asscess so that variables in WRF output don't have to be read in in specific order
+!> 2011-02-06 | J Wang | Add grib2 option
+!> 2011-12-14 | Sarah Lu | Add the option to read ngac aer file
+!> 2012-01-28 | J WANG | Use post available fields in xml file for grib2
+!> 2013-06-25 | S Moorthi | Add gocart_on logical option to save memory
+!> 2013-10-03 | J Wang |Add option for po to be pascal, and add gocart_on,d3d_on and popascal to namelist
+!> 2020-03-25 | J Meng | Remove grib1
+!> 2021-06-20 | W Meng | Remove reading grib1 and gfsio lib
+!> 2021-07-07 | J MENG |2D DECOMPOSITION
+!> 2021-10-22 | KaYee Wong | Created formal fortran namelist for itag
+!> 2021-11-03 | Tracy Hertneky | Removed SIGIO option
+!> 2022-01-14 | W Meng | Remove interfaces INITPOST_GS_NEMS, INITPOST_NEMS_MPIIO, INITPOST_NMM and INITPOST_GFS_NETCDF
+!> 2022-03-15 | W Meng | Unify FV3 based interfaces
+!>
+!> @author Mike Bladwin NSSL/SPC @date 2002-06-18
PROGRAM WRFPOST
!
@@ -142,12 +109,13 @@ PROGRAM WRFPOST
use CTLBLK_mod, only: filenameaer, me, num_procs, num_servers, mpi_comm_comp, datestr, &
mpi_comm_inter, filename, ioform, grib, idat, filenameflux, filenamed3d, gdsdegr, &
spldef, modelname, ihrst, lsmdef,vtimeunits, tprec, pthresh, datahandle, im, jm, lm, &
- lp1, lm1, im_jm, isf_surface_physics, nsoil, spl, lsmp1, global, &
+ lp1, lm1, im_jm, isf_surface_physics, nsoil, spl, lsmp1, global, imp_physics, &
+ ista, iend, ista_m, iend_m, ista_2l, iend_2u, &
jsta, jend, jsta_m, jend_m, jsta_2l, jend_2u, novegtype, icount_calmict, npset, datapd,&
lsm, fld_info, etafld2_tim, eta2p_tim, mdl2sigma_tim, cldrad_tim, miscln_tim, &
- mdl2agl_tim, mdl2std_tim, mdl2thandpv_tim, calrad_wcloud_tim, &
+ mdl2agl_tim, mdl2std_tim, mdl2thandpv_tim, calrad_wcloud_tim, &
fixed_tim, time_output, imin, surfce2_tim, komax, ivegsrc, d3d_on, gocart_on,rdaod, &
- readxml_tim, spval, fullmodelname, submodelname, hyb_sigp, filenameflat, aqfcmaq_on
+ readxml_tim, spval, fullmodelname, submodelname, hyb_sigp, filenameflat, aqfcmaq_on,numx
use grib2_module, only: gribit2,num_pset,nrecout,first_grbtbl,grib_info_finalize
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
implicit none
@@ -173,7 +141,7 @@ PROGRAM WRFPOST
integer :: kpo,kth,kpv
real,dimension(komax) :: po,th,pv
namelist/nampgb/kpo,po,kth,th,kpv,pv,fileNameAER,d3d_on,gocart_on,popascal &
- ,hyb_sigp,rdaod,aqfcmaq_on,vtimeunits
+ ,hyb_sigp,rdaod,aqfcmaq_on,vtimeunits,numx
integer :: itag_ierr
namelist/model_inputs/fileName,IOFORM,grib,DateStr,MODELNAME,SUBMODELNAME &
,fileNameFlux,fileNameFlat
@@ -220,6 +188,7 @@ PROGRAM WRFPOST
!KaYee: Read itag in Fortran Namelist format
!Set default
SUBMODELNAME='NONE'
+ numx=1
!open namelist
open(5,file='itag')
read(5,nml=model_inputs,iostat=itag_ierr,err=888)
@@ -228,6 +197,7 @@ PROGRAM WRFPOST
print*,'Incorrect namelist variable(s) found in the itag file,stopping!'
stop
endif
+
if (me==0) print*,'fileName= ',fileName
if (me==0) print*,'IOFORM= ',IOFORM
!if (me==0) print*,'OUTFORM= ',grib
@@ -235,6 +205,7 @@ PROGRAM WRFPOST
if (me==0) print*,'DateStr= ',DateStr
if (me==0) print*,'MODELNAME= ',MODELNAME
if (me==0) print*,'SUBMODELNAME= ',SUBMODELNAME
+ if (me==0) print*,'numx= ',numx
! if(MODELNAME == 'NMM')then
! read(5,1114) VTIMEUNITS
! 1114 format(a4)
@@ -272,11 +243,6 @@ PROGRAM WRFPOST
,trim(fileName),trim(fileNameFlux)
end if
-!
-! set ndegr
-! if(grib=='grib1') then
-! gdsdegr = 1000.
-! else if (grib=='grib2') then
if(grib=='grib2') then
gdsdegr = 1.d6
endif
@@ -302,21 +268,51 @@ PROGRAM WRFPOST
!set control file name
fileNameFlat='postxconfig-NT.txt'
-!KaYee if(MODELNAME == 'RAPR') then
-!KaYee read(5,*,iostat=iret,end=119) kpo
-!KaYee else
- read(5,nampgb,iostat=iret,end=119)
-!KaYee endif
-! if(kpo > komax)print*,'pressure levels cannot exceed ',komax; STOP
-! if(kth > komax)print*,'isent levels cannot exceed ',komax; STOP
-! if(kpv > komax)print*,'PV levels cannot exceed ',komax; STOP
+ read(5,nampgb,iostat=iret,end=119)
119 continue
+ if (me==0) print*,'in itag, mod(num_procs,numx)=', mod(num_procs,numx)
+ if(mod(num_procs,numx)/=0) then
+ if (me==0) then
+ print*,'total proces, num_procs=', num_procs
+ print*,'number of subdomain in x direction, numx=', numx
+ print*,'remainder of num_procs/numx = ', mod(num_procs,numx)
+ print*,'Warning!!! the remainder of num_procs/numx is not 0, reset numx=1 &
+ & in this run or you adjust numx in the itag file to restart'
+ endif
+! stop 9999
+ numx=1
+ if(me == 0) print*,'Warning!!! Reset numx as 1, numx=',numx
+ endif
+ if(numx>num_procs/2) then
+ if (me==0) then
+ print*,'total proces, num_procs=', num_procs
+ print*,'number of subdomain in x direction, numx=', numx
+ print*,'Warning!!! numx cannot exceed num_procs/2, reset numx=1 in this run'
+ print*,'or you adjust numx in the itag file to restart'
+ endif
+ numx=1
+ if(me == 0) print*,'Warning!!! Reset numx as 1, numx=',numx
+ endif
if(me == 0) then
print*,'komax,iret for nampgb= ',komax,iret
print*,'komax,kpo,kth,th,kpv,pv,fileNameAER,popascal= ',komax,kpo &
& ,kth,th(1:kth),kpv,pv(1:kpv),trim(fileNameAER),popascal
+ print*,'NUM_PROCS=',NUM_PROCS
+ print*,'numx= ',numx
endif
+ IF(TRIM(IOFORM) /= 'netcdfpara' .AND. TRIM(IOFORM) /= 'netcdf' ) THEN
+ numx=1
+ if(me == 0) print*,'2D decomposition only supports netcdfpara IO.'
+ if(me == 0) print*,'Reset numx= ',numx
+ ENDIF
+
+ IF(MODELNAME /= 'FV3R' .AND. MODELNAME /= 'GFS') THEN
+ numx=1
+ if(me == 0) print*,'2D decomposition only supports GFS and FV3R.'
+ if(me == 0) print*,'Reset numx= ',numx
+ ENDIF
+
! set up pressure level from POSTGPVARS or DEFAULT
if(kpo == 0) then
! use default pressure levels
@@ -332,15 +328,6 @@ PROGRAM WRFPOST
if(me == 0) then
print*,'using pressure levels from POSTGPVARS'
endif
-!KaYee if(MODELNAME == 'RAPR')then
-!KaYee read(5,*) (po(l),l=1,kpo)
-! CRA READ VALID TIME UNITS
-!KaYee read(5,121) VTIMEUNITS
-!KaYee if(me == 0) then
-!KaYee print*,'VALID TIME UNITS = ', VTIMEUNITS
-!KaYee endif
-! CRA
-!KaYee endif
lsm = kpo
if( .not. popascal ) then
untcnvt = 100.
@@ -360,21 +347,8 @@ PROGRAM WRFPOST
LSMP1 = LSM+1
if (me==0) print*,'LSM, SPL = ',lsm,spl(1:lsm)
-!Chuang, Jun and Binbin: If model is RSM, read in precip accumulation frequency (sec) from unit5
- if(MODELNAME == 'RSM') then
- read(5,115)PRNTSEC
- TPREC = PRNTSEC/3600.0
- print*,'TPREC in RSM= ',TPREC
- end if
- 115 format(f7.1)
116 continue
-!KaYee if(MODELNAME == 'GFS') then
-! read(5,*) line
-!KaYee read(5,111,end=125) fileNameFlat
-!KaYee 125 continue
-! if(len_trim(fileNameFlat)<5) fileNameFlat = 'postxconfig-NT.txt'
-!KaYee if (me == 0) print*,'Post flat name in GFS= ',trim(fileNameFlat)
-!KaYee endif
+
! set PTHRESH for different models
if(MODELNAME == 'NMM')then
PTHRESH = 0.000004
@@ -382,7 +356,7 @@ PROGRAM WRFPOST
PTHRESH = 0.000001
end if
!Chuang: add dynamical allocation
- if(TRIM(IOFORM) == 'netcdf') THEN
+ if(TRIM(IOFORM) == 'netcdf' .OR. TRIM(IOFORM) == 'netcdfpara') THEN
IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR' .OR. MODELNAME == 'NMM') THEN
call ext_ncd_ioinit(SysDepInfo,Status)
print*,'called ioinit', Status
@@ -426,14 +400,16 @@ PROGRAM WRFPOST
call ext_ncd_ioclose ( DataHandle, Status )
ELSE
-! use netcdf lib directly to read FV3 output in netCDF
+! use parallel netcdf lib directly to read FV3 output in netCDF
spval = 9.99e20
- Status = nf90_open(trim(fileName),NF90_NOWRITE, ncid3d)
+ Status = nf90_open(trim(fileName),IOR(NF90_NOWRITE,NF90_MPIIO), &
+ ncid3d,comm=mpi_comm_world,info=mpi_info_null)
if ( Status /= 0 ) then
print*,'error opening ',fileName, ' Status = ', Status
stop
endif
- Status = nf90_open(trim(fileNameFlux),NF90_NOWRITE, ncid2d)
+ Status = nf90_open(trim(fileNameFlux),IOR(NF90_NOWRITE,NF90_MPIIO), &
+ ncid2d,comm=mpi_comm_world,info=mpi_info_null)
if ( Status /= 0 ) then
print*,'error opening ',fileNameFlux, ' Status = ', Status
stop
@@ -454,6 +430,13 @@ PROGRAM WRFPOST
endif
if(me==0)print*,'SF_SURFACE_PHYSICS= ',iSF_SURFACE_PHYSICS
if(me==0)print*,'NSOIL= ',NSOIL
+! read imp_physics
+ Status=nf90_get_att(ncid2d,nf90_global,'imp_physics',imp_physics)
+ if(Status/=0)then
+ print*,'imp_physics not found; assigning to GFDL 11'
+ imp_physics=11
+ endif
+ if (me == 0) print*,'MP_PHYSICS= ',imp_physics
! get dimesions
Status = nf90_inq_dimid(ncid3d,'grid_xt',varid)
if ( Status /= 0 ) then
@@ -494,53 +477,6 @@ PROGRAM WRFPOST
print*,'im jm lm nsoil from fv3 output = ',im,jm,lm,nsoil
END IF
-! use netcdf_parallel lib directly to read FV3 output in netCDF
- ELSE IF(TRIM(IOFORM) == 'netcdfpara') THEN
- spval = 9.99e20
- Status = nf90_open(trim(fileName),ior(nf90_nowrite, nf90_mpiio), &
- ncid3d, comm=mpi_comm_world, info=mpi_info_null)
- if ( Status /= 0 ) then
- print*,'error opening ',fileName, ' Status = ', Status
- stop
- endif
-! get dimesions
- Status = nf90_inq_dimid(ncid3d,'grid_xt',varid)
- if ( Status /= 0 ) then
- print*,Status,varid
- STOP 1
- end if
- Status = nf90_inquire_dimension(ncid3d,varid,len=im)
- if ( Status /= 0 ) then
- print*,Status
- STOP 1
- end if
- Status = nf90_inq_dimid(ncid3d,'grid_yt',varid)
- if ( Status /= 0 ) then
- print*,Status,varid
- STOP 1
- end if
- Status = nf90_inquire_dimension(ncid3d,varid,len=jm)
- if ( Status /= 0 ) then
- print*,Status
- STOP 1
- end if
- Status = nf90_inq_dimid(ncid3d,'pfull',varid)
- if ( Status /= 0 ) then
- print*,Status,varid
- STOP 1
- end if
- Status = nf90_inquire_dimension(ncid3d,varid,len=lm)
- if ( Status /= 0 ) then
- print*,Status
- STOP 1
- end if
- LP1 = LM+1
- LM1 = LM-1
- IM_JM = IM*JM
-! set NSOIL to 4 as default for NOAH but change if using other
-! SFC scheme
- NSOIL = 4
- print*,'im jm lm nsoil from fv3 output = ',im,jm,lm,nsoil
ELSE IF(TRIM(IOFORM) == 'binary' .OR. &
TRIM(IOFORM) == 'binarympiio' ) THEN
@@ -644,28 +580,18 @@ PROGRAM WRFPOST
! Reading model output for different models and IO format
- IF(TRIM(IOFORM) == 'netcdf') THEN
+ IF(TRIM(IOFORM) == 'netcdf' .OR. TRIM(IOFORM) == 'netcdfpara') THEN
IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR') THEN
print*,'CALLING INITPOST TO PROCESS NCAR NETCDF OUTPUT'
CALL INITPOST
- ELSE IF(MODELNAME == 'NMM') THEN
- print*,'CALLING INITPOST_NMM TO PROCESS NMM NETCDF OUTPUT'
- CALL INITPOST_NMM
- ELSE IF (MODELNAME == 'FV3R') THEN
-! use netcdf library to read output directly
+ ELSE IF (MODELNAME == 'FV3R' .OR. MODELNAME == 'GFS') THEN
+! use parallel netcdf library to read output directly
print*,'CALLING INITPOST_NETCDF'
CALL INITPOST_NETCDF(ncid2d,ncid3d)
- ELSE IF (MODELNAME == 'GFS') THEN
- print*,'CALLING INITPOST_GFS_NETCDF'
- CALL INITPOST_GFS_NETCDF(ncid3d)
ELSE
PRINT*,'POST does not have netcdf option for model,',MODELNAME,' STOPPING,'
STOP 9998
END IF
-! use netcdf_parallel library to read fv3 output
- ELSE IF(TRIM(IOFORM) == 'netcdfpara') THEN
- print*,'CALLING INITPOST_GFS_NETCDF_PARA'
- CALL INITPOST_GFS_NETCDF_PARA(ncid3d)
ELSE IF(TRIM(IOFORM) == 'binarympiio') THEN
IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR' .OR. MODELNAME == 'NMM') THEN
print*,'WRF BINARY IO FORMAT IS NO LONGER SUPPORTED, STOPPING'
@@ -680,10 +606,6 @@ PROGRAM WRFPOST
ELSE IF(TRIM(IOFORM) == 'binarynemsio') THEN
IF(MODELNAME == 'NMM') THEN
CALL INITPOST_NEMS(NREC,nfile)
- ELSE IF(MODELNAME == 'GFS') THEN
-! CALL INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,nfile,ffile)
- CALL INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,iostatusAER, &
- nfile,ffile,rfile)
ELSE
PRINT*,'POST does not have nemsio option for model,',MODELNAME,' STOPPING,'
STOP 9998
@@ -691,11 +613,7 @@ PROGRAM WRFPOST
END IF
ELSE IF(TRIM(IOFORM) == 'binarynemsiompiio')THEN
- IF(MODELNAME == 'NMM') THEN
-! close nemsio file for serial read
- call nemsio_close(nfile,iret=status)
- CALL INITPOST_NEMS_MPIIO()
- ELSE IF(MODELNAME == 'GFS') THEN
+ IF(MODELNAME == 'GFS') THEN
! close nemsio file for serial read
call nemsio_close(nfile,iret=status)
call nemsio_close(ffile,iret=status)
@@ -776,11 +694,15 @@ PROGRAM WRFPOST
CALL SET_OUTFLDS(kth,th,kpv,pv)
if (me==0) write(0,*)' in WRFPOST size datapd',size(datapd)
if(allocated(datapd)) deallocate(datapd)
- allocate(datapd(im,1:jend-jsta+1,nrecout+100))
+!Jesse x-decomposition
+! allocate(datapd(im,1:jend-jsta+1,nrecout+100))
+ allocate(datapd(1:iend-ista+1,1:jend-jsta+1,nrecout+100))
!$omp parallel do private(i,j,k)
do k=1,nrecout+100
do j=1,jend+1-jsta
- do i=1,im
+!Jesse x-decomposition
+! do i=1,im
+ do i =1,iend+1-ista
datapd(i,j,k) = 0.
enddo
enddo
diff --git a/sorc/ncep_post.fd/ZENSUN.f b/sorc/ncep_post.fd/ZENSUN.f
index a0c0412fb..4c46415b6 100644
--- a/sorc/ncep_post.fd/ZENSUN.f
+++ b/sorc/ncep_post.fd/ZENSUN.f
@@ -1,75 +1,63 @@
!> @file
-! . . . .
-!> subprogram: zensun make sun zenith and sun azimuth angle
-!!
-!! prgmmr: Paul Ricchiazzi org: Earth Space Research Group,UCSB date: 1992-10-23
-!!
-!! abstract:
-!! Compute solar position information as a function of
-!! geographic coordinates, date and time.
-!!
-!! program history log:
-!! 2005-10-21 kazumori - reformatted for GSI
-!!
-!! input argument list:
-!! day - Julian day (positive scalar or vector)
-!! (spring equinox = 80)
-!! (summer solstice= 171)
-!! (fall equinox = 266)
-!! (winter solstice= 356)
-!! time - Universal Time in hours (scalar or vector)
-!! lat - geographic latitude of point on earth's surface (degrees)
-!! lon - geographic longitude of point on earth's surface (degrees)
-!!
-!! output argument list:
-!! sun_zenith - solar zenith angle
-!! sun_azimuth - solar azimuth angle
-!!
-!! comments:
-!!
-!!
-!! PROCEDURE:
-!!
-!! 1. Calculate the subsolar point latitude and longitude, based on
-!! DAY and TIME. Since each year is 365.25 days long the exact
-!! value of the declination angle changes from year to year. For
-!! precise values consult THE AMERICAN EPHEMERIS AND NAUTICAL
-!! ALMANAC published yearly by the U.S. govt. printing office. The
-!! subsolar coordinates used in this code were provided by a
-!! program written by Jeff Dozier.
-!!
-!! 2. Given the subsolar latitude and longitude, spherical geometry is
-!! used to find the solar zenith, azimuth and flux multiplier.
-!!
-!! eqt = equation of time (minutes) ! solar longitude correction = -15*eqt
-!! dec = declination angle (degrees) = solar latitude
-!!
-!! LOWTRAN v7 data (25 points)
-!! The LOWTRAN solar position data is characterized by only 25 points.
-!! This should predict the subsolar angles within one degree. For
-!! increased accuracy add more data points.
-!!
-!!nday=[ 1., 9., 21., 32., 44., 60., 91., 121., 141., 152.,$
-!! 160., 172., 182., 190., 202., 213., 244., 274., 305., 309.,$
-!! 325., 335., 343., 355., 366.]
-!!
-!!eqt=[ -3.23, -6.83,-11.17,-13.57,-14.33,-12.63, -4.2, 2.83, 3.57, 2.45,$
-!! 1.10, -1.42, -3.52, -4.93, -6.25, -6.28,-0.25, 10.02, 16.35, 16.38,$
-!! 14.3, 11.27, 8.02, 2.32, -3.23]
-!!
-!!dec=[-23.07,-22.22,-20.08,-17.32,-13.62, -7.88, 4.23, 14.83, 20.03, 21.95,$
-!! 22.87, 23.45, 23.17, 22.47, 20.63, 18.23, 8.58, -2.88,-14.18,-15.45,$
-!! -19.75,-21.68,-22.75,-23.43,-23.07]
-!!
-!! Analemma information from Jeff Dozier
-!! This data is characterized by 74 points
-!!
-!!
-!! attributes:
-!! language: f90
-!! machine: ibm RS/6000 SP
-!!
-!!
+!> zensun() makes sun zenith and sun azimuth angle.
+!>
+!> @author Paul Ricchiazzi Earth Space Research Group,UCSB @date 1992-10-23
+
+!> This subroutine computes solar position information as a function of
+!> geographic coordinates, date and time.
+!>
+!>
+!> @note Procedure:
+!>
+!> 1. Calculate the subsolar point latitude and longitude, based on
+!> DAY and TIME. Since each year is 365.25 days long the exact
+!> value of the declination angle changes from year to year. For
+!> precise values consult THE AMERICAN EPHEMERIS AND NAUTICAL
+!> ALMANAC published yearly by the U.S. govt. printing office. The
+!> subsolar coordinates used in this code were provided by a
+!> program written by Jeff Dozier.
+!>
+!> 2. Given the subsolar latitude and longitude, spherical geometry is
+!> used to find the solar zenith, azimuth and flux multiplier.
+!>
+!> eqt = equation of time (minutes) ! solar longitude correction = -15*eqt
+!> dec = declination angle (degrees) = solar latitude
+!>
+!> LOWTRAN v7 data (25 points)
+!> The LOWTRAN solar position data is characterized by only 25 points.
+!> This should predict the subsolar angles within one degree. For
+!> increased accuracy add more data points.
+!>
+!> nday=[ 1., 9., 21., 32., 44., 60., 91., 121., 141., 152.,$
+!> 160., 172., 182., 190., 202., 213., 244., 274., 305., 309.,$
+!> 325., 335., 343., 355., 366.]
+!>
+!> eqt=[ -3.23, -6.83,-11.17,-13.57,-14.33,-12.63, -4.2, 2.83, 3.57, 2.45,$
+!> 1.10, -1.42, -3.52, -4.93, -6.25, -6.28,-0.25, 10.02, 16.35, 16.38,$
+!> 14.3, 11.27, 8.02, 2.32, -3.23]
+!>
+!> dec=[-23.07,-22.22,-20.08,-17.32,-13.62, -7.88, 4.23, 14.83, 20.03, 21.95,$
+!> 22.87, 23.45, 23.17, 22.47, 20.63, 18.23, 8.58, -2.88,-14.18,-15.45,$
+!> -19.75,-21.68,-22.75,-23.43,-23.07]
+!>
+!> Analemma information from Jeff Dozier
+!>
+!> This data is characterized by 74 points.
+!>
+!>
+!> @param[in] day Julian day (positive scalar or vector), (spring equinox = 80), (summer solstice= 171), (fall equinox = 266), (winter solstice= 356).
+!> @param[in] time Universal Time in hours (scalar or vector).
+!> @param[in] lat Geographic latitude of point on earth's surface (degrees).
+!> @param[in] lon Geographic longitude of point on earth's surface (degrees).
+!> @param[out] sun_zenith - solar zenith angle.
+!> @param[out] sun_azimuth - solar azimuth angle.
+!>
+!> ### Program history log:
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2005-10-21 | kazumori | Reformatted for GSI
+!>
+!> @author Paul Ricchiazzi Earth Space Research Group,UCSB @date 1992-10-23
subroutine zensun(day,time,lat,lon,pi,sun_zenith,sun_azimuth)
!
diff --git a/sorc/ncep_post.fd/build_upp_lib.sh b/sorc/ncep_post.fd/build_upp_lib.sh
deleted file mode 100755
index b3a01dae3..000000000
--- a/sorc/ncep_post.fd/build_upp_lib.sh
+++ /dev/null
@@ -1,54 +0,0 @@
-SHELL=/bin/sh
-
-module purge
-set -x
-mac=$(hostname | cut -c1-1)
-mac2=$(hostname | cut -c1-2)
-
-if [ $mac2 = hf ] ; then # For Hera
- machine=hera
- . /etc/profile
- . /etc/profile.d/modules.sh
-elif [ $mac = f ] ; then # For Jet
- machine=jet
- . /etc/profile
- . /etc/profile.d/modules.sh
-elif [ $mac = v -o $mac = m ] ; then # For Dell
- machine=wcoss_dell_p3
- . $MODULESHOME/init/bash
-elif [ $mac = t -o $mac = e -o $mac = g ] ; then # For WCOSS
- machine=wcoss
- . /usrx/local/Modules/default/init/bash
-elif [ $mac2 = s4 ] ; then # For S4
- machine=s4
- . /etc/profile
-elif [ $mac = l -o $mac = s ] ; then # wcoss_c (i.e. luna and surge)
- export machine=cray-intel
-elif [ $mac = O ] ; then # For Orion
- machine=orion
- . /etc/profile
-fi
-export version=${1:-"v8.0.0"}
-
-moduledir=`dirname $(readlink -f ../../modulefiles/post)`
-module use -a ${moduledir}
-module load upp/lib-${machine}
-#module load nceppost_modulefile
-
-#
-module list
-
-#sleep 1
-
-BASE=`pwd`
-
-#####################################
-cd ${BASE}
-rm *.o *.mod incmod
-#mkdir -m 775 -p $BASE/../../lib/include/ncep_post_${version}_4
-make -f makefile_lib clean
-mkdir -m 775 -p include/upp_4
-make -f makefile_lib
-
-exit 0
-
diff --git a/sorc/ncep_post.fd/grib2_module.f b/sorc/ncep_post.fd/grib2_module.f
index 35c064c53..bb24fc660 100644
--- a/sorc/ncep_post.fd/grib2_module.f
+++ b/sorc/ncep_post.fd/grib2_module.f
@@ -10,6 +10,8 @@ module grib2_module
! are defined in xml file
! March, 2015 Lin Gan Replace XML file with flat file implementation
! with parameter marshalling
+! July, 2021 Jesse Meng 2D decomsition
+! June, 2022 Lin Zhu change the dx/dy to reading in from calculating for latlon grid
!------------------------------------------------------------------------
use xml_perl_data, only: param_t,paramset_t
!
@@ -197,7 +199,7 @@ end subroutine grib_info_finalize
subroutine gribit2(post_fname)
!
!-------
- use ctlblk_mod, only : im,jm,im_jm,num_procs,me,jsta,jend,ifhr,sdat,ihrst,imin, &
+ use ctlblk_mod, only : im,jm,im_jm,num_procs,me,ista,iend,jsta,jend,ifhr,sdat,ihrst,imin, &
mpi_comm_comp,ntlfld,fld_info,datapd,icnt,idsp
implicit none
!
@@ -215,6 +217,7 @@ subroutine gribit2(post_fname)
integer(4),allocatable :: isdsp(:),iscnt(:),ircnt(:),irdsp(:)
integer status(MPI_STATUS_SIZE)
integer(kind=MPI_OFFSET_KIND) idisp
+ integer,allocatable :: ista_pe(:),iend_pe(:)
integer,allocatable :: jsta_pe(:),jend_pe(:)
integer,allocatable :: grbmsglen(:)
real,allocatable :: datafld(:,:)
@@ -253,6 +256,12 @@ subroutine gribit2(post_fname)
!--- reditribute data from partial domain data with all fields
!--- to whole domain data but partial fields
!
+ allocate(ista_pe(num_procs),iend_pe(num_procs))
+ call mpi_allgather(ista,1,MPI_INTEGER,ista_pe,1, &
+ MPI_INTEGER,MPI_COMM_COMP,ierr)
+ call mpi_allgather(iend,1,MPI_INTEGER,iend_pe,1, &
+ MPI_INTEGER,MPI_COMM_COMP,ierr)
+
allocate(jsta_pe(num_procs),jend_pe(num_procs))
call mpi_allgather(jsta,1,MPI_INTEGER,jsta_pe,1, &
MPI_INTEGER,MPI_COMM_COMP,ierr)
@@ -269,18 +278,19 @@ subroutine gribit2(post_fname)
!
!--- sequatial write if the number of fields to write is small
!
- if(minval(nfld_pe)<1.or.num_procs==1) then
+!JESSE if(minval(nfld_pe)<1.or.num_procs==1) then
+ if(num_procs==1) then
!
!-- collect data to pe 0
allocate(datafld(im_jm,ntlfld) )
- if(num_procs==1) then
+! if(num_procs==1) then
datafld=reshape(datapd,(/im_jm,ntlfld/))
- else
- do i=1,ntlfld
- call mpi_gatherv(datapd(:,:,i),icnt(me),MPI_REAL, &
- datafld(:,i),icnt,idsp,MPI_REAL,0,MPI_COMM_COMP,ierr)
- enddo
- endif
+! else
+! do i=1,ntlfld
+! call mpi_gatherv(datapd(:,:,i),icnt(me),MPI_REAL, &
+! datafld(:,i),icnt,idsp,MPI_REAL,0,MPI_COMM_COMP,ierr)
+! enddo
+! endif
!
!-- pe 0 create grib2 message and write to the file
if(me==0) then
@@ -339,13 +349,13 @@ subroutine gribit2(post_fname)
allocate(ircnt(num_procs),irdsp(num_procs))
isdsp(1)=0
do n=1,num_procs
- iscnt(n)=(jend_pe(me+1)-jsta_pe(me+1)+1)*im*nfld_pe(n)
+ iscnt(n)=(jend_pe(me+1)-jsta_pe(me+1)+1)*(iend_pe(me+1)-ista_pe(me+1)+1)*nfld_pe(n)
if(n
+!> @brief This module is to hold specification kinds for variable declaration.
+!> This module is based on (copied from) Paul vanDelst's
+!> type_kinds module found in the community radiative transfer model.
+!>
+!> @note The numerical data types defined in this module are:
+!> Variables name | Numerical data types
+!> ---------------|------------
+!> i_byte | specification kind for byte (1-byte) integer variable
+!> i_short | specification kind for short (2-byte) integer variable
+!> i_long | specification kind for long (4-byte) integer variable
+!> i_llong | specification kind for double long (8-byte) integer variable
+!> r_single | specification kind for single precision (4-byte) real variable
+!> r_double | specification kind for double precision (8-byte) real variable
+!> r_quad | specification kind for quad precision (16-byte) real variable
+!> i_kind | generic specification kind for default integer
+!> r_kind | generic specification kind for default floating point
+!>
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2004-08-15 | Russ Treadon | Initial
+!>
+!> @author Russ Treadon np23 @date 2004-08-15
+
module kinds
implicit none
diff --git a/sorc/ncep_post.fd/makefile b/sorc/ncep_post.fd/makefile
deleted file mode 100644
index 7a0a614d8..000000000
--- a/sorc/ncep_post.fd/makefile
+++ /dev/null
@@ -1,258 +0,0 @@
-#!/bin/ksh
-set -x
-mac=$(hostname | cut -c1-1)
-mac2=$(hostname | cut -c1-2)
-################################# options ###############################################
-#export CLEAN=NO # comment this line to clean before compiling
-#debug=YES # turn on debug mode - default - NO
- make_post_lib=YES # create post library - default - NO
- make_post_exec=YES # create post executable - default - YES
-#make_nowrf=YES # compile with wrf stub instead of WRF lib
-################################# options ###############################################
-#
-if [ $mac2 = ga ] ; then # For GAEA
- machine=gaea
- center=${center:-ncep}
- make_nowrf=${make_nowrf:-YES} # to compile with wrf stub instead of WRF lib
-elif [ $mac2 = tf ] ; then # For Theia
- machine=theia
- make_nowrf=${make_nowrf:-YES} # to compile with wrf stub instead of WRF lib
-elif [ $mac = z -o $mac = h -o $mac = f ] ; then # For ZEUS
- machine=zeus
- make_nowrf=${make_nowrf:-YES} # to compile with wrf stub instead of WRF lib
-elif [ $mac = t -o $mac = e -o $mac = g ] ; then # For WCOSS
- machine=wcoss
-elif [ $mac = l -o $mac = s ] ; then # wcoss_c (i.e. luna and surge)
- export machine=wcoss_c
- make_nowrf=${make_nowrf:-YES} # to compile with wrf stub instead of WRF lib
-fi
-debug=${debug:-NO}
-export make_post_lib=${make_post_lib:-NO}
-export make_post_exec=${make_post_exec:-YES}
-export make_nowrf=${make_nowrf:- NO}
-if [ $machine = wcoss ] ; then
- export NETCDFPATH="/usrx/local/NetCDF/3.6.3"
- export WRFPATH="/nwprod/sorc/wrf_shared.v1.1.0"
- export NWPROD="/nwprod"
- export XMLPATH=$NWPROD
- export IPPATH=$NWPROD
- export SPPATH=/usrx/local/nceplibs
- export BACIOPATH=/usrx/local/nceplibs
- export ipv=""
- export spv=_v2.0.2p
- export crtmv=2.0.6
- export crtmv_inc=$crtmv
- export xmlv=_v2.0.0
- export baciov=_v2.0.1p
- export FC=mpiifort
- export CPP="/lib/cpp -P"
- export CPPFLAGS="-DLINUX"
- export CC=cc
- if [ $debug = YES ] ; then
- export OPTS="-O0 -openmp "
- export DEBUG="-g -traceback -convert big_endian -ftrapuv -check bounds -check format -check output_conversion -check pointers -check uninit -fp-stack-check"
- else
- export OPTS="-O3 -convert big_endian -fp-model source -openmp -xAVX"
- export DEBUG=""
- fi
- export LIST=""
- export FREE="-FR"
- export TRAPS=""
- export PROFILE=""
-elif [ $machine = wcoss_c ] ; then
- export FC=ftn
- export CPP="/lib/cpp -P"
- export CPPFLAGS="-DLINUX"
- export CC=cc
- if [ $debug = YES ] ; then
- export OPTS="-O0 -openmp "
- export DEBUG="-g -traceback -convert big_endian -ftrapuv -check bounds -check format -check output_conversion -check pointers -check uninit -fp-stack-check"
- else
- export OPTS="-O3 -convert big_endian -fp-model source -openmp -xAVX"
- export DEBUG=""
- fi
- export LIST=""
- export FREE="-FR"
- export TRAPS=""
- export PROFILE=""
-elif [ $machine = zeus ] ; then
- export NETCDFPATH="/apps/netcdf/3.6.3/intel"
- export WRFPATH="/scratch2/portfolios/NCEPDEV/meso/save/Dusan.Jovic/WRFV3"
- export NWPROD="/contrib/nceplibs/nwprod"
- export XMLPATH="/home/Hui-Ya.Chuang"
- export IPPATH=$NWPROD
- export SPPATH=$NWPROD
- export ipv=""
- export spv=_v2.0.1
- export crtmv=2.0.7
- export FC="ifort -lmpi"
- export CPP="/lib/cpp -P"
- export CC=cc
- export ARCH=""
- export CPPFLAGS="-DLINUX"
- if [ $debug = YES ] ; then
- export OPTS="-O0 -openmp -g"
- export DEBUG="-g -check all -ftrapuv -convert big_endian -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback"
- else
- export export OPTS="-O3 -convert big_endian -traceback -g -fp-model source -openmp"
- export DEBUG=""
- fi
- export LIST=""
- export FREE="-FR"
- export TRAPS=""
- export PROFILE=""
-elif [ $machine = theia ] ; then
- export NETCDFPATH="/apps/netcdf/4.3.0-intel"
- export WRFPATH="/scratch4/NCEPDEV/global/save/Shrinivas.Moorthi/theia/nceplibs/nwprod/lib/sorc/WRFV3"
- export NWPROD="/scratch4/NCEPDEV/global/save/Shrinivas.Moorthi/theia/nceplibs/nwprod"
- export ipv=_v2.0.3
- export spv=""
- export crtmv=2.0.7
- export gfsiov=""
- export w3ev=_v2.1.0
- export w3nv=""
- export xmlv=_v2.0.0
- export g2tv=""
- export baciov=_v2.1.0
- export XMLPATH=$NWPROD
- export IPPATH=$NWPROD
- export SPPATH=$NWPROD
- export BACIOPATH=$NWPROD/lib
- export FC=mpiifort
- export CPP="/lib/cpp -P"
- export CC=cc
- export ARCH=""
- export CPPFLAGS="-DLINUX"
- if [ $debug = YES ] ; then
- export OPTS="-O0 -openmp -g"
- export DEBUG="-g -check all -ftrapuv -convert big_endian -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback"
- else
- export export OPTS="-O3 -convert big_endian -traceback -g -fp-model source -openmp"
- export DEBUG=""
- fi
- export LIST=""
- export FREE="-FR"
- export TRAPS=""
- export PROFILE=""
-elif [ $machine = gaea ] ; then
- export NETCDFPATH="/opt/cray/netcdf/4.3.2/INTEL/140"
- export WRFPATH="/lustre/f1/unswept/ncep/Shrinivas.Moorthi/nceplibs/nwprod/lib/sorc/WRFV3"
- export NWPROD="/lustre/f1/unswept/ncep/Shrinivas.Moorthi/nceplibs/nwprod"
- export IPPATH=$NWPROD
- export SPPATH=$NWPROD
- export baciov=_v2.1.0
- export BACIOPATH=/lustre/f1/unswept/ncep/Shrinivas.Moorthi/nceplibs/nwprod/lib/sorc/bacio_fast_byteswap/bacio${baciov}_4
- export ipv=""
- export spv=_v2.0.1
- export xmlv=_v2.0.0
- export FC=ftn
- export CPP="/lib/cpp -P"
- export ARCH=""
- export CPPFLAGS="-DLINUX"
- export CC=icc
- if [ $debug = YES ] ; then
- export OPTS="-O0 -g"
- export DEBUG="-g -check all -ftrapuv -convert big_endian -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback"
- else
- export export OPTS="-O3 -convert big_endian -traceback -g -fp-model source"
- export DEBUG=""
- fi
- export LIST=""
- export FREE=-FR
- export TRAPS=""
- export PROFILE=""
-
- export gfsiov=""
- export crtmv=2.0.7
- export w3ev=_v2.1.0
- export w3nv=""
-fi
-export crtmv=${crtmv:-2.0.7}
-export crtmv_inc=${crtmv_inc:-v$crtmv}
-export XMLPATH=${XMLPATH:-$NWPROD}
-export BACIOPATH=${BACIOPATH:-$NWPROD/lib}
-export xmlv=${xmlv:-""}
-export w3ev=${w3ev:-_v2.0.3}
-export ipv=${ipv:-""}
-export spv=${spv:-""}
-
-if [ ${CLEAN:-YES} = YES ] ; then make -f Makefile clean ; fi
-
-export CFLAGS="-DLINUX -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long'"
-if [ $machine = wcoss_c ] ; then
-
- if [ $make_nowrf = YES ] ; then
- WRF_INC=
- WRF_LIB=
- fi
- NETCDF_LIB="${NETCDF}/lib/libnetcdf.a"
- export FFLAGS="${OPTS} ${FREE} ${TRAPS} ${DEBUG} -I${XMLPARSE_INC} -I${G2_INC4} -I${G2TMPL_INC} -I${NEMSIO_INC} -I${SIGIO_INC4} -I${SFCIO_INC4} -I${GFSIO_INC4} -I${W3EMC_INC4} -I${CRTM_INC} -I${NETCDF_INCLUDE} -I${PNG_INC}"
-
- export LIBS="${WRF_LIB} ${XMLPARSE_LIB} ${G2_LIB4} ${G2TMPL_LIB} ${NEMSIO_LIB} ${GFSIO_LIB4} ${SIGIO_LIB4} ${SFCIO_LIB4} ${IP_LIB4} ${SP_LIB4} ${W3NCO_LIB4} ${W3EMC_LIB4} ${BACIO_LIB4} ${CRTM_LIB} ${NETCDF_LIB} ${PNG_LIB} ${JASPER_LIB} ${Z_LIB}"
-else
- SFCIO_INC="-I${NWPROD}/lib/incmod/sfcio_4"
- SFCIO_LIB="${NWPROD}/lib/libsfcio_4.a"
-
- NEMSIO_INC="-I${NWPROD}/lib/incmod/nemsio"
- NEMSIO_LIB="-L${NWPROD}/lib -lnemsio"
- BACIO_LIB="-L${BACIOPATH} -lbacio${baciov}_4"
- SIGIO_INC="-I${NWPROD}/lib/incmod/sigio_4"
- SIGIO_LIB="${NWPROD}/lib/libsigio_4.a"
- NCDLIBS="-L${NETCDFPATH} -lnetcdf"
- NCDFFLAGS="-I${NETCDFPATH}"
- if [ $make_nowrf = YES ] ; then
- WRF_INC=
- WRF_LIB=
- else
- WRF_INC="-I${WRFPATH}/external/io_quilt -I${WRFPATH}/frame"
- WRF_LIB="${WRFPATH}/main/libwrflib.a ${WRFPATH}/frame/pack_utils.o ${WRFPATH}/frame/module_internal_header_util.o ${WRFPATH}/external/io_grib1/libio_grib1.a ${WRFPATH}/external/io_grib_share/libio_grib_share.a ${WRFPATH}/external/io_int/libwrfio_int.a ${WRFPATH}/external/io_netcdf/libwrfio_nf.a ${WRFPATH}/external/esmf_time_f90/libesmf_time.a ${WRFPATH}/external/RSL_LITE/librsl_lite.a"
- fi
-
- G2_INC="-I${NWPROD}/lib/incmod/g2_4 -I${NWPROD}/lib/incmod/g2tmpl${g2tv}"
- G2_LIB="-L${NWPROD}/lib -lg2tmpl${g2tv} -lg2_4 -ljasper -lpng -lz"
-
- GFSIO_INC="-I${NWPROD}/lib/incmod/gfsio${gfsiov}_4"
- GFSIO_LIB="-L${NWPROD}/lib -lgfsio${gfsiov}_4"
-
- IP_LIB="-L${IPPATH}/lib -lip${ipv}_4"
- SP_LIB="-L${SPPATH} -lsp${sp}_4"
-
- W3_INC="-I${NWPROD}/lib/incmod/w3emc${w3ev}_4"
- W3_LIB="-L${NWPROD}/lib -lw3nco${w3nv}_4 -lw3emc${w3ev}_4"
-
- CRTM_INC="-I${NWPROD}/lib/incmod/crtm_${crtmv_inc}"
- CRTM_LIB="-L${NWPROD}/lib -lcrtm_v${crtmv}"
- XML_INC="-I${XMLPATH}/lib/incmod/xmlparse${xmlv}"
- XML_LIB="-L${XMLPATH}/lib -lxmlparse${xmlv}"
-
- NETCDF_LIB="${NETCDFPATH}/lib/libnetcdf.a"
- NETCDF_INC="-I${NETCDFPATH}/include"
-
- export FFLAGS="${OPTS} ${FREE} ${TRAPS} ${DEBUG} ${WRF_INC} ${XML_INC} ${G2_INC} ${NEMSIO_INC} ${GFSIO_INC} ${SIGIO_INC} ${SFCIO_INC} ${W3_INC} ${CRTM_INC} ${NETCDF_INC}"
-
- export LIBS="${WRF_LIB} ${XML_LIB} ${G2_LIB} ${NEMSIO_LIB} ${GFSIO_LIB} ${SIGIO_LIB} ${SFCIO_LIB} ${IP_LIB} ${SP_LIB} ${W3_LIB} ${BACIO_LIB} ${CRTM_LIB} ${NETCDF_LIB}"
-
-fi
-if [ $make_post_lib = NO ] ; then
- if [ $make_post_exec = YES ] ; then
- if [ $make_nowrf = YES ] ; then
- _make -f Makefile_nowrf
- else
- make -f Makefile
- fi
- fi
-else
- if [ $make_post_exec = YES ] ; then
- if [ $make_nowrf = YES ] ; then
- make -f Makefile_nowrf
- else
- make -f Makefile
- fi
- fi
- export POSTLIBPATH=${POSTLIBPATH:-$(pwd)}
- if [ ${CLEAN:-YES} = YES ] ; then rm -rf $POSTLIBPATH/include/post_4 ; fi
- mkdir -p $POSTLIBPATH/include/post_4
- make -f Makefile_lib
-fi
-
-
diff --git a/sorc/ncep_post.fd/makefile_dtc b/sorc/ncep_post.fd/makefile_dtc
deleted file mode 100644
index 519c2418b..000000000
--- a/sorc/ncep_post.fd/makefile_dtc
+++ /dev/null
@@ -1,130 +0,0 @@
-SHELL = /bin/sh
-
-################################################################################
-#
-# Makefile for NCEP Post
-#
-# Use:
-# make - build the executable
-# make clean - start with a clean slate
-#
-#################################################################################
-#
-# Define the name of the executable
-#
-TARGET = unipost.exe
-
-#
-# build configuration determined before compile
-include ../../configure.upp
-
-#
-# directories for shared resources
-LOCALINC = -I$(INCMOD) -I$(INCMOD)/crtm2
-NCDFINC = -I$(NETCDFPATH)/include
-GRIB2INC = -I$(GRIB2SUPT_INC)
-
-LLIBDIR = -L$(LIBDIR)
-UPPLIBS = -lCRTM $(SERIAL_MPI_LIB) -lxmlparse
-NCEPLIBS = $(NCEPLIBLIB) $(NCEPLIB_FLAGS) $(GRIB2SUPT_LIB)
-NCDFLIBS = -L$(NETCDFPATH)/lib $(NETCDFLIBS)
-
-LIBS = $(LLIBDIR) $(UPPLIBS) $(GRIB2LIBS) $(NCEPLIBS) $(NCDFLIBS)
-
-MODULES =
-
-#
-# Compilation / Link Flag Configuration
-EXTRA_CPPFLAGS =
-EXTRA_FFLAGS = -c $(LOCALINC) $(NETCDFINC) $(NCDFINC) $(NCEPLIBINC)
-#EXTRA_LDFLAGS = $(LIBS) -Wl,-Map=lm
-EXTRA_LDFLAGS = $(LIBS)
-EXTRA_CFLAGS = -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long'
-
-#
-# -----------
-# Threaded object files
-# -----------
-OBJS_FT = wrf_io_flags.o getVariable.o \
- getIVariableN.o kinds_mod.o machine.o physcons.o \
- native_endianness.o \
- retrieve_index.o ZENSUN.o \
- CLDFRAC_ZHAO.o GFSPOST.o GFSPOSTSIG.o GETGBANDSCATTER.o \
- blockIO.o
-
-# -----------
-# Non-threaded object files
-# -----------
-#OBJXML = post_t.o
-
-OBJS_F = VRBLS2D_mod.o VRBLS3D_mod.o VRBLS4D_mod.o MASKS_mod.o PMICRPH.o SOIL_mod.o CMASSI.o \
- CTLBLK.o GRIDSPEC.o \
- LOOKUP.o PARAMR.o RHGRD.o RQSTFLD.o xml_perl_data.o cuparm.o params.o svptbl.o get_postfilename.o grib2_module.o \
- SET_LVLSXML.o FILL_PSETFLD.o BNDLYR.o BOUND.o CALCAPE.o \
- CALDWP.o CALDRG.o CALHEL.o CALLCL.o CALMCVG.o CALPOT.o CALPW.o CALRH.o CALRCH.o \
- CALRH_GSD.o CALSTRM.o CALTAU.o CALTHTE.o CALVIS.o CALVIS_GSD.o CALVOR.o CALWXT.o $(LINUX_OBJ)\
- CALWXT_RAMER.o CALWXT_BOURG.o CALWXT_REVISED.o CALRH_PW.o CALWXT_EXPLICIT.o \
- CALWXT_DOMINANT.o CLDRAD.o \
- CLMAX.o COLLECT.o COLLECT_LOC.o DEWPOINT.o FDLVL.o FGAMMA.o FIXED.o FRZLVL.o FRZLVL2.o \
- GET_BITS.o INITPOST.o LFMFLD.o MAPSSLP.o MISCLN.o MDL2STD_P.o MIXLEN.o MDL2P.o ETAMP_Q2F.o \
- MDLFLD.o MPI_FIRST.o MPI_LAST.o NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o SLP_NMM.o \
- EXCH.o PARA_RANGE.o PROCESS.o INITPOST_NMM.o EXCH2.o READCNTRL.o READ_xml.o \
- SET_OUTFLDS.o SCLFLD.o SERVER.o \
- SETUP_SERVERS.o SMOOTH.o SURFCE.o SPLINE.o TABLE.o TABLEQ.o TRPAUS.o TTBLEX.o WETBULB.o \
- WRFPOST.o CALMICT.o MICROINIT.o GPVS.o MDL2SIGMA.o ETCALC.o CANRES.o \
- CALGUST.o WETFRZLVL.o SNFRAC.o MDL2AGL.o SNFRAC_GFS.o AVIATION.o DEALLOCATE.o \
- CALPBL.o MDL2SIGMA2.o INITPOST_GFS.o CALRH_GFS.o LFMFLD_GFS.o \
- CALRAD_WCLOUD_newcrtm.o MDL2THANDPV.o CALPBLREGIME.o POLEAVG.o INITPOST_NEMS.o \
- GETNEMSNDSCATTER.o ICAOHEIGHT.o INITPOST_GFS_NEMS.o \
- GEO_ZENITH_ANGLE.o GFIP3.o GRIDAVG.o CALUPDHEL.o MSFPS.o INITPOST_GFS_SIGIO.o\
- AllGETHERV_GSD.o SELECT_CHANNELS.o ALLOCATE_ALL.o INITPOST_NEMS_MPIIO.o ASSIGNNEMSIOVAR.o INITPOST_GFS_NEMS_MPIIO.o \
- INITPOST_NETCDF.o INITPOST_GFS_NETCDF.o \
- gtg_ctlblk.o gtg_indices.o gtg_filter.o gtg_compute.o gtg_config.o map_routines.o gtg_algo.o CALVESSEL.o \
- CALHEL2.o CALCAPE2.o
-
-OBJS = $(OBJS_F) $(OBJXML) $(OBJS_FT)
-
-# -----------
-# Targets
-# -----------
-all: $(TARGET)
-
-$(TARGET): $(XML_DEPS) $(OBJS) $(MODULES)
- $(F90) -o $@ $(FFLAGS) $(MODULES) $(OBJS) $(LDFLAGS) $(EXTRA_LDFLAGS)
- $(CP) $@ $(BINDIR)
-
-# This insures a dependency found in some files -- watch file order above remains -- should
-# be done w/ dependencies
-$(OBJS_F): $(OBJS_FT) $(OBJXML)
-
-#
-# These files are configurable, but rarely change
-clean:
- @echo -e "\n<><><><> CLEAN <><><><>\n$@ in `pwd`"
- $(RM) $(TARGET) $(OBJS) *.lst *.mod
- $(RM) $(BINDIR)/$(TARGET)
- for f in `ls -1 *.F|sed "s/.F$$/.f/"` ; do \
- $(RM) $$f ; \
- done
-
-distclean: clean
-
-.IGNORE:
-.PHONY: clean
-
-.SUFFIXES:
-.SUFFIXES: .F .f .f90 .o .c
-
-.F.o:
- $(CPP) $(CPP_FLAGS) $(EXTRA_CPPFLAGS) $< > $*.f
- $(F90) -c $(FFLAGS) $(EXTRA_FFLAGS) $*.f
-
-.f.o:
- $(F90) -c $(FFLAGS) $(EXTRA_FFLAGS) $<
-
-.f90.o:
- $(F90) -c $(FFLAGS) $(EXTRA_FFLAGS) $<
-
-.c.o:
- ${CC} -c ${CFLAGS} $(EXTRA_CFLAGS) $<
-
diff --git a/sorc/ncep_post.fd/makefile_lib b/sorc/ncep_post.fd/makefile_lib
deleted file mode 100644
index 37d48af6e..000000000
--- a/sorc/ncep_post.fd/makefile_lib
+++ /dev/null
@@ -1,146 +0,0 @@
-################################################################################
-#
-# Makefile for upp (NCEP Post)
-#
-# Use:
-# make - build the executable
-# make clean - start with a clean slate
-#
-# The following macros will be of interest:
-#
-# TARGET - name of the executable
-# FC - name of Fortran compiler
-# CPP - name of CPP
-# ARCH - architecture
-# CPPFLAGS - CPP flags
-# OPTS - compiler code optimizations
-# LIST - source listing
-# SMP - threading
-# TRAPS - runtime traps for floating point exceptions
-# PROFILE - source code profiling ( -pg )
-# DEBUG - -g
-# MEM - user data area and stack size
-# MAP - load map
-# W3LIB - w3lib
-# BACIO - bacio lib
-# ESSL - ESSL library
-# MASS - MASS library
-# HPMLIB - hpm lib
-# SEARCH - library search location
-#
-# This version for eta_post with more intelligent memory allocation
-# Jim Tuccillo Feb 2001
-#
-# This version for eta_post with asynchronous I/O server.
-# Jim Tuccillo June 2001
-
-# This version for NEMS_POST
-# Jun Wang June 2010
-#
-# This version for GFS V16 in-line post
-# Wen Meng Ocotomber 2020
-#
-#################################################################################
-#
-# Define the name of the executable
-#
- #POSTLIBPATH=../..
- #TARGET = ${POSTLIBPATH}/lib/libncep_post_${version}_4.a
- #INCMOD= ${POSTLIBPATH}/lib/include/ncep_post_${version}_4
- TARGET = libupp_4.a
- INCMOD = include/upp_4
- AR = ar
- ARFLAGS = -rv
-
-#
-# CPP, Compiler, and Linker Options
-#
-
-#FC = mpfort -compiler ifort
-#CPP = /lib/cpp -P
-FC = $(myFC) $(myFCFLAGS)
-CPP = $(myCPP) $(myCPPFLAGS)
-ARCH = auto
-CPPFLAGS = -DLINUX
-OPTS = -O -fp-model strict
-LIST =
-FREE = -FR
-#TRAPS = -qflttrap=ov:und:zero:inv:inex -qcheck -qinitauto=FF
-TRAPS =
-PROFILE =
-DEBUG = -g
-CFLAGS = -DLINUX -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long'
-W3LIBDIR = /nwprod/lib
-
-SEARCH =
-#
-# Assemble Options
-#
-#FFLAGS = $(OPTS) $(FREE) $(TRAPS) $(DEBUG) -I$(CRTM_INC) -I$(W3EMC_INC4) -I$(G2_INC4) -I$(G2TMPL_INC) -I$(XMLPARSE_INC) -I$(SIGIO_INC4) -I$(GFSIO_INC4)
-FFLAGS = $(OPTS) $(FREE) $(TRAPS) $(DEBUG) -I$(CRTM_INC) -I$(W3EMC_INC4) -I$(G2_INC4) -I$(G2TMPL_INC) -I$(SIGIO_INC4) -I$(GFSIO_INC4)
-FFLAGST = $(OPTS) $(FREE) $(TRAPS) $(DEBUG) -I$(CRTM_INC) -I$(W3EMC_INC4) -I$(SIGIO_INC4) -I$(GFSIO_INC4)
-
-#
-# Threaded object files
-#
-OBJST= kinds_mod.o machine.o physcons.o ZENSUN.o CLDFRAC_ZHAO.o GFSPOST.o
-#
-# Non-threaded object files
-#
-#OBJXML= post_t.o
-#
-OBJS= VRBLS2D_mod.o VRBLS3D_mod.o VRBLS4D_mod.o MASKS_mod.o PMICRPH.o SOIL_mod.o \
- CMASSI.o CTLBLK.o GRIDSPEC.o LOOKUP.o PARAMR.o RHGRD.o RQSTFLD.o xml_perl_data.o \
- cuparm.o params.o svptbl.o get_postfilename.o grib2_module.o \
- SET_LVLSXML.o FILL_PSETFLD.o \
- BNDLYR.o BOUND.o CALCAPE.o CALDWP.o CALDRG.o CALHEL.o CALLCL.o \
- CALMCVG.o CALPOT.o CALPW.o CALRH.o CALRCH.o CALRH_GSD.o \
- CALSTRM.o CALTAU.o CALTHTE.o CALVIS.o CALVIS_GSD.o CALVOR.o CALWXT.o \
- CALWXT_RAMER.o CALWXT_BOURG.o CALWXT_REVISED.o CALRH_PW.o \
- CALWXT_EXPLICIT.o CALWXT_DOMINANT.o \
- CLDRAD.o CLMAX.o COLLECT.o COLLECT_LOC.o DEWPOINT.o \
- FDLVL.o FGAMMA.o FIXED.o FRZLVL.o FRZLVL2.o \
- GET_BITS.o LFMFLD.o \
- MAPSSLP.o MISCLN.o MDL2STD_P.o MIXLEN.o MDL2P.o MDLFLD.o \
- NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o SLP_NMM.o EXCH.o \
- PARA_RANGE.o PROCESS.o EXCH2.o \
- READCNTRL.o READ_xml.o SET_OUTFLDS.o SCLFLD.o \
- SMOOTH.o SURFCE.o \
- SPLINE.o TABLE.o TABLEQ.o TRPAUS.o TTBLEX.o WETBULB.o \
- CALMICT.o MICROINIT.o GPVS.o MDL2SIGMA.o \
- ETCALC.o CANRES.o CALGUST.o WETFRZLVL.o SNFRAC.o MDL2AGL.o SNFRAC_GFS.o \
- AVIATION.o DEALLOCATE.o \
- CALPBL.o MDL2SIGMA2.o CALRH_GFS.o LFMFLD_GFS.o \
- CALRAD_WCLOUD_newcrtm.o MDL2THANDPV.o CALPBLREGIME.o POLEAVG.o \
- ICAOHEIGHT.o \
- GEO_ZENITH_ANGLE.o GFIP3.o GRIDAVG.o CALUPDHEL.o \
- AllGETHERV_GSD.o MSFPS.o SELECT_CHANNELS.o ALLOCATE_ALL.o \
- gtg_ctlblk.o gtg_indices.o gtg_filter.o gtg_compute.o gtg_config.o map_routines.o gtg_algo.o gtg_smoothseams.o CALVESSEL.o \
- CALHEL2.o CALCAPE2.o
-
-
-.SUFFIXES: .F .f .o .f90 .c
-
-.F.f:
- $(CPP) $(CPPFLAGS) $< > $*.f
-
-$(TARGET): $(OBJST) $(OBJXML) $(OBJS)
- $(AR) $(ARFLAGS) $@ $(OBJST) $(OBJXML) $(OBJS) $(LIBS)
- mv *.mod $(INCMOD)
-
-.f.o:
- $(FC) $(FFLAGS) -c $<
-
-.f90.o:
- $(FC) $(FFLAGS) -c $<
-
-.c.o :
- ${CC} ${CFLAGS} -c $<
-
-clean:
- /bin/rm -rf libupp_*.a *.lst *.o include
-#
-#postcntrl_t.o : postcntrl_t.f90
-# $(FC) $(FFLAGS) postcntrl_t.f90
-
-
diff --git a/sorc/ncep_post.fd/makefile_module b/sorc/ncep_post.fd/makefile_module
deleted file mode 100644
index 5b6f2c763..000000000
--- a/sorc/ncep_post.fd/makefile_module
+++ /dev/null
@@ -1,126 +0,0 @@
-###################################################################################################
-# post implement module load standard
-#
-# 10/15 Lin Gan: Create module load version
-# 12/07 Lin Gan: Update to generate post module output
-# 07/16 J. Carley: Generalize for multiple machines
-#
-###################################################################################################
-
-SHELL=/bin/bash
-#
-# Define the name of the executable
-#
-# To generate exe as ncep_post
-TARGET = ncep_post
-LIB_TARGET = libnceppost.a
-AR = ar
-ARFLAGS = ruv
-
-#
-# CPP, Compiler, and Linker Options
-#
-
-FC = $(myFC) $(myFCFLAGS)
-CPP = $(myCPP) $(myCPPFLAGS)
-CPPFLAGS = -DLINUX
-FREE = -FR
-
-NETCDF_INC = -I$(NETCDF)/include
-#NETCDF_LDFLAGS = -L$(NETCDF)/lib -lnetcdff -lnetcdf
-NETCDF_LDFLAGS = -L$(NETCDF)/lib -lnetcdff -lnetcdf -L$(HDF5_LDFLAGS) $(Z_LIB)
-
-CFLAGS = -DLINUX -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long'
-
-FFLAGS = $(OPTS) $(FREE) $(DEBUG) \
- -I$(SFCIO_INC4) \
- -I$(NEMSIO_INC) \
- -I$(SIGIO_INC4) \
- -I$(G2_INC4) \
- -I$(G2TMPL_INC) \
- -I$(GFSIO_INC4) \
- -I$(W3EMC_INC4) \
- -I$(CRTM_INC) \
- -I$(IP_INC4) \
- $(NETCDF_INC)
-
-LIBS = $(WRFIO_LIB) \
- $(G2TMPL_LIB) \
- $(G2_LIB4) \
- $(JASPER_LIB) \
- $(PNG_LIB) \
- $(Z_LIB) \
- $(NEMSIO_LIB) \
- $(GFSIO_LIB4) \
- $(SIGIO_LIB4) \
- $(SFCIO_LIB4) \
- $(IP_LIB4) \
- $(SP_LIB4) \
- $(W3EMC_LIB4) \
- $(W3NCO_LIB4) \
- $(BACIO_LIB4) \
- $(CRTM_LIB) \
- $(NETCDF_LDFLAGS)
-
-
-OBJS = wrf_io_flags.o getVariable.o getIVariableN.o \
- kinds_mod.o machine.o physcons.o \
- native_endianness.o blockIO.o \
- retrieve_index.o ZENSUN.o CLDFRAC_ZHAO.o \
- GFSPOST.o GFSPOSTSIG.o GETGBANDSCATTER.o \
- VRBLS2D_mod.o VRBLS3D_mod.o VRBLS4D_mod.o MASKS_mod.o PMICRPH.o SOIL_mod.o \
- CMASSI.o CTLBLK.o GRIDSPEC.o LOOKUP.o PARAMR.o RHGRD.o RQSTFLD.o xml_perl_data.o \
- cuparm.o params.o svptbl.o get_postfilename.o grib2_module.o \
- SET_LVLSXML.o FILL_PSETFLD.o \
- UPP_MATH.o UPP_PHYSICS.o \
- BNDLYR.o BOUND.o CALDWP.o CALDRG.o CALHEL.o CALLCL.o \
- CALMCVG.o CALPOT.o CALPW.o CALRCH.o \
- CALSTRM.o CALTAU.o CALTHTE.o CALVIS.o CALVIS_GSD.o CALVOR.o CALWXT.o \
- CALWXT_RAMER.o CALWXT_BOURG.o CALWXT_REVISED.o \
- CALWXT_EXPLICIT.o CALWXT_DOMINANT.o \
- CLDRAD.o CLMAX.o COLLECT.o COLLECT_LOC.o DEWPOINT.o \
- FDLVL.o FGAMMA.o FIXED.o FRZLVL.o FRZLVL2.o \
- GET_BITS.o INITPOST.o LFMFLD.o \
- MAPSSLP.o MISCLN.o MDL2STD_P.o MIXLEN.o MDL2P.o MDLFLD.o MPI_FIRST.o MPI_LAST.o \
- NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o SLP_NMM.o EXCH.o \
- PARA_RANGE.o PROCESS.o INITPOST_NMM.o EXCH2.o \
- READCNTRL.o READ_xml.o SET_OUTFLDS.o SCLFLD.o SERVER.o SETUP_SERVERS.o \
- SMOOTH.o SURFCE.o \
- SPLINE.o TABLE.o TABLEQ.o TRPAUS.o TTBLEX.o WETBULB.o WRFPOST.o \
- CALMICT.o MICROINIT.o GPVS.o MDL2SIGMA.o \
- ETCALC.o CANRES.o CALGUST.o WETFRZLVL.o SNFRAC.o MDL2AGL.o SNFRAC_GFS.o \
- AVIATION.o DEALLOCATE.o \
- CALPBL.o MDL2SIGMA2.o INITPOST_GFS.o LFMFLD_GFS.o \
- CALRAD_WCLOUD_newcrtm.o MDL2THANDPV.o CALPBLREGIME.o POLEAVG.o \
- INITPOST_NEMS.o GETNEMSNDSCATTER.o ICAOHEIGHT.o INITPOST_GFS_NEMS.o \
- GEO_ZENITH_ANGLE.o GFIP3.o CALUPDHEL.o INITPOST_GFS_SIGIO.o \
- AllGETHERV_GSD.o MSFPS.o SELECT_CHANNELS.o ALLOCATE_ALL.o INITPOST_NEMS_MPIIO.o ASSIGNNEMSIOVAR.o \
- INITPOST_GFS_NEMS_MPIIO.o INITPOST_NETCDF.o INITPOST_GFS_NETCDF.o INITPOST_GFS_NETCDF_PARA.o \
- gtg_ctlblk.o gtg_indices.o gtg_filter.o gtg_compute.o gtg_config.o map_routines.o gtg_algo.o gtg_smoothseams.o CALVESSEL.o \
- CALHEL2.o ETAMP_Q2F.o
-
-
-.SUFFIXES: .F .f .o .f90 .c
-
-.F.f:
- $(CPP) $(CPPFLAGS) $< > $*.f
-
-$(TARGET): $(OBJST) $(OBJS)
- $(FC) -o $@ $(OBJST) $(OBJS) $(LIBS) $(OPENMP)
- mkdir -p include/post_4
- $(AR) $(ARFLAGS) $(LIB_TARGET) $(OBJST) $(OBJS)
- mv *.mod include/post_4
-
-.f.o:
- $(FC) $(FFLAGS) -c $<
-
-.f90.o:
- $(FC) $(FFLAGS) -c $<
-
-.c.o :
- ${CC} ${CFLAGS} -c $<
-
-
-clean:
- /bin/rm -f *.o *.mod libnceppost.a ncep_post
- /bin/rm -rf include
diff --git a/sorc/ncep_post.fd/native_endianness.f b/sorc/ncep_post.fd/native_endianness.f
index acfadaacd..c0003e4fe 100644
--- a/sorc/ncep_post.fd/native_endianness.f
+++ b/sorc/ncep_post.fd/native_endianness.f
@@ -1,35 +1,26 @@
!> @file
-! . . . .
-!> module: native_endianness
-!! prgmmr: parrish org: wx22 date: 2012-10-11
-!!
-!! abstract: This module was written by Dusan Jovic and has been adapted to GSI for internal translation
-!! of WRF ARW and NMM binary restart files as required to match the machine native
-!! endian storage format. The original code only converted from big-endian to little-endian.
-!! There are no restrictions in this version.
-!! This is required for these two types of files, because they are read/written to using mpi-io,
-!! which has no compiler option for automatic switching to machine native endian format
-!! for fortran unformatted read/write.
-!!
-!! program history log:
-!! 2012-10-11 parrish - copy/modify original module native_endianness provided by Dusan Jovic, NCEP/EMC 2012
-!! 2012-10-19 parrish - additional modifications to improve efficiency. Remove interface and make
-!! to_native_endianness to work only with integer(4) arguments.
-!! Put to_native_endianness_i4 outside module.
-!!
-!! subroutines included:
-!!
-!! functions included:
-!! is_little_endian - no argument--returns true for little-endian machine, false for big-endian machine
-!!
-!! variables included:
-!! byte_swap - false if machine and wrf binary file are same endian, true if different
-!!
-!! attributes:
-!! language: f90
-!! machine:
-!!
-!!
+!>
+!> @brief This module, native_endianness, was written by Dusan Jovic and has been adapted to GSI for internal translation
+!> of WRF ARW and NMM binary restart files as required to match the machine native
+!> endian storage format. The original code only converted from big-endian to little-endian.
+!> There are no restrictions in this version.
+!> This is required for these two types of files, because they are read/written to using mpi-io,
+!> which has no compiler option for automatic switching to machine native endian format
+!> for fortran unformatted read/write.
+!>
+!> @author Parrish wx22 @date 2012-10-11
+
+!> @note functions included: is_little_endian - no argument--returns true for little-endian machine, false for big-endian machine
+!>
+!> @note variables included: byte_swap - false if machine and wrf binary file are same endian, true if different
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2012-10-11 | Parrish | Initial. Copy/modify original module native_endianness provided by Dusan Jovic, NCEP/EMC 2012
+!> 2012-10-19 | parrish | Additional modifications to improve efficiency. Remove interface and make to_native_endianness to work only with integer(4) arguments. Put to_native_endianness_i4 outside module.
+!>
+!> @author Parrish wx22 @date 2012-10-11
module native_endianness
@@ -46,26 +37,14 @@ module native_endianness
contains
logical function is_little_endian()
-!$$$ subprogram documentation block
-! . . . .
-! subprogram: is_little_endian
-! prgmmr: parrish org: wx22 date: 2012-10-11
-!
-! abstract: test to see if machine is little-endian. Returns true for little-endian, false for big-endian.
-!
-! program history log:
-! 2012-10-11 parrish - add doc block
-!
-! input argument list:
-!
-! output argument list:
-!
-! attributes:
-! language: f90
-! machine:
-!
-!$$$ end documentation block
-
+!> is_little_endian() tests to see if machine is little-endian. Returns true for little-endian, false for big-endian.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2012-10-11 | Parrish | Add doc block
+!>
+!> @author Parrish wx22 @date 2012-10-11
implicit none
integer(i_byte) :: i1
@@ -86,32 +65,19 @@ end module native_endianness
!----------------------------------------------------------------------
subroutine to_native_endianness_i4(i4,num)
-!$$$ subprogram documentation block
-! . . . .
-! subprogram: to_native_endianness_i4
-! prgmmr: parrish org: wx22 date: 2012-10-11
-!
-! abstract: swap bytes of argument.
-!
-! program history log:
-! 2012-10-11 parrish - add doc block
-! 2012-10-19 parrish - additional modifications to improve efficiency. Remove interface and make
-! to_native_endianness to work only with integer(4) arguments.
-! Put to_native_endianness_i4 outside module.
-!
-! input argument list:
-! i4 - input 4 byte integer array
-! num - length of array i4 (NOTE: type of num must be i_llong (8 byte integer) )
-!
-! output argument list:
-! i4 - output 4 byte integer array with bytes in reverse order
-!
-! attributes:
-! language: f90
-! machine:
-!
-!$$$ end documentation block
-
+!> to_native_endianness_i4() is to swap bytes of argument.
+!>
+!> @param[in] i4 Input 4 byte integer array.
+!> @param[in] num Length of array i4. (NOTE: type of num must be i_llong (8 byte integer) )
+!> @param[out] i4 Output 4 byte integer array with bytes in reverse order.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2012-10-11 | Parrish | Add doc block
+!> 2012-10-19 | Parrish | Additional modifications to improve efficiency. Remove interface and make to_native_endianness to work only with integer(4) arguments. Put to_native_endianness_i4 outside module.
+!>
+!> @author Parrish wx22 @date 2012-10-11
use kinds, only: i_byte,i_long,i_llong
implicit none
diff --git a/sorc/ncep_post.fd/post_gtg.fd b/sorc/ncep_post.fd/post_gtg.fd
new file mode 160000
index 000000000..b7e077699
--- /dev/null
+++ b/sorc/ncep_post.fd/post_gtg.fd
@@ -0,0 +1 @@
+Subproject commit b7e077699ca1054104cc93342a038941346bef04
diff --git a/sorc/ncep_post.fd/retrieve_index.f b/sorc/ncep_post.fd/retrieve_index.f
index ebacab31a..1fb390378 100644
--- a/sorc/ncep_post.fd/retrieve_index.f
+++ b/sorc/ncep_post.fd/retrieve_index.f
@@ -1,31 +1,22 @@
!> @file
-! . . . .
-!> subprogram: retrieve_index get record number of desired variable
-!! prgmmr: parrish org: np22 date: 2004-11-29
-!!
-!! abstract: by examining previously generated inventory of wrf binary restart file,
-!! find record number that contains the header record for variable
-!! identified by input character variable "string".
-!!
-!! program history log:
-!! 2004-11-29 parrish
-!!
-!! input argument list:
-!! string - mnemonic for variable desired
-!! varname_all - list of all mnemonics obtained from inventory of file
-!! nrecs - total number of sequential records counted in wrf
-!! binary restart file
-!!
-!! output argument list:
-!! index - desired record number
-!! iret - return status, set to 0 if variable was found,
-!! non-zero if not.
-!!
-!! attributes:
-!! language: f90
-!! machine: ibm RS/6000 SP
-!!
-!!
+!> @brief retrieve_index() gets record number of desired variable.
+!>
+!> By examining previously generated inventory of wrf binary restart file,
+!> find record number that contains the header record for variable
+!> identified by input character variable "string".
+!>
+!> @param[in] string Mnemonic for variable desired.
+!> @param[in] varname_all List of all mnemonics obtained from inventory of file.
+!> @param[in] nrecs Total number of sequential records counted in wrf binary restart file.
+!> @param[out] index Desired record number.
+!> @param[out] iret Return status, set to 0 if variable was found, non-zero if not.
+!>
+!> ### Program History Log
+!> Date | Programmer | Comments
+!> -----|------------|---------
+!> 2004-11-29 | Parrish | Initial
+!>
+!> @author Parrish np22 @date 2004-11-29
subroutine retrieve_index(index,string,varname_all,nrecs,iret)
diff --git a/tests/compile_upp.sh b/tests/compile_upp.sh
index 94360f243..2c20f660c 100755
--- a/tests/compile_upp.sh
+++ b/tests/compile_upp.sh
@@ -1,13 +1,53 @@
#!/bin/bash
# Wen Meng 01/2020, Set up for cmake build.
-#############################################
+# Wen Meng 01/2022, Add option for building with gtg code
+############################################################
-set -x
+set -eu
-#Clean loaded modules
-module purge
+usage() {
+ echo
+ echo "Usage: $0 [-p] [-g] [-w] [-v] [-c] -h"
+ echo
+ echo " -p installation prefix DEFAULT: ../install"
+ echo " -g build with GTG(users with gtg repos. access only) DEFAULT: OFF"
+ echo " -w build without WRF-IO DEFAULT: ON"
+ echo " -v build with cmake verbose DEFAULT: NO"
+ echo " -c Compiler to use for build DEFAULT: intel"
+ echo " -h display this message and quit"
+ echo
+ exit 1
+}
+
+prefix="../install"
+gtg_opt=" -DBUILD_WITH_GTG=OFF"
+wrfio_opt=" -DBUILD_WITH_WRFIO=ON"
+compiler="intel"
+verbose_opt=""
+while getopts ":p:gwc:vh" opt; do
+ case $opt in
+ p)
+ prefix=$OPTARG
+ ;;
+ g)
+ gtg_opt=" -DBUILD_WITH_GTG=ON"
+ ;;
+ w)
+ wrfio_opt=" -DBUILD_WITH_WRFIO=OFF"
+ ;;
+ c)
+ compiler=$OPTARG
+ ;;
+ v)
+ verbose_opt="VERBOSE=1"
+ ;;
+ h|\?|:)
+ usage
+ ;;
+ esac
+done
+cmake_opts=" -DCMAKE_INSTALL_PREFIX=$prefix"${wrfio_opt}${gtg_opt}
-hostname
source ./detect_machine.sh
if [[ $(uname -s) == Darwin ]]; then
readonly MYDIR=$(cd "$(dirname "$(greadlink -f -n "${BASH_SOURCE[0]}" )" )" && pwd -P)
@@ -17,15 +57,32 @@ fi
PATHTR=${PATHTR:-$( cd ${MYDIR}/.. && pwd )}
#Load required modulefiles
-module use $PATHTR/modulefiles
-modulefile=${MACHINE_ID}
-module load $modulefile
-module list
+if [[ $MACHINE_ID != "unknown" ]]; then
+ if [[ $MACHINE_ID == "wcoss2" ]]; then
+ module reset
+ else
+ module purge
+ fi
+ module use $PATHTR/modulefiles
+ if [[ $compiler == "intel" ]]; then
+ modulefile=${MACHINE_ID}
+ else
+ modulefile=${MACHINE_ID}_${compiler}
+ fi
+ if [ -f "${PATHTR}/modulefiles/${modulefile}" -o -f "${PATHTR}/modulefiles/${modulefile}.lua" ]; then
+ echo "Building for machine ${MACHINE_ID}, compiler ${compiler}"
+ else
+ echo "Modulefile does not exist for machine ${MACHINE_ID}, compiler ${compiler}"
+ exit 1
+ fi
+ module load $modulefile
+ module list
+fi
rm -rf build install
mkdir build && cd build
-cmake -DCMAKE_INSTALL_PREFIX=../install -DBUILD_WITH_WRFIO=ON ../..
-make -j6
+cmake $cmake_opts ../..
+make -j6 $verbose_opt
make install
rm -rf $PATHTR/exec && mkdir $PATHTR/exec
diff --git a/tests/detect_machine.sh b/tests/detect_machine.sh
index 9362e5635..7620dc004 100755
--- a/tests/detect_machine.sh
+++ b/tests/detect_machine.sh
@@ -16,6 +16,12 @@ case $(hostname -f) in
v72a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus
v72a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus
v72a3.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus
+ v109a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus
+ v109a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus
+ v109a3.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus
+ v110a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus
+ v110a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus
+ v110a3.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus
m71a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars
m71a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars
@@ -23,9 +29,35 @@ case $(hostname -f) in
m72a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars
m72a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars
m72a3.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars
-
- alogin01) MACHINE_ID=wcoss2 ;; ### acorn
- alogin02) MACHINE_ID=wcoss2 ;; ### acorn
+ m109a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars
+ m110a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars
+ m109a3.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars
+ m110a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars
+ m110a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars
+ m110a3.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars
+
+ alogin01.acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2_a ;; ### acorn
+ alogin02.acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2_a ;; ### acorn
+ adecflow01.acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### acorn
+ adecflow02.acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### acorn
+ dlogin01.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood
+ dlogin02.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood
+ dlogin03.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood
+ dlogin04.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood
+ dlogin05.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood
+ dlogin06.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood
+ dlogin07.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood
+ dlogin08.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood
+ dlogin09.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood
+ clogin01.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus
+ clogin02.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus
+ clogin03.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus
+ clogin04.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus
+ clogin05.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus
+ clogin06.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus
+ clogin07.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus
+ clogin08.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus
+ clogin09.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus
gaea9) MACHINE_ID=gaea ;; ### gaea9
gaea10) MACHINE_ID=gaea ;; ### gaea10
@@ -92,6 +124,8 @@ case $(hostname -f) in
login4.stampede2.tacc.utexas.edu) MACHINE_ID=stampede ;; ### stampede4
s4-submit.ssec.wisc.edu) MACHINE_ID=s4 ;; ### S4
+
+ *) MACHINE_ID=unknown
esac
# Overwrite auto-detect with RT_MACHINE if set
diff --git a/ush/fv3gfs_downstream_nems.sh b/ush/fv3gfs_downstream_nems.sh
index b2f625de3..149b02021 100755
--- a/ush/fv3gfs_downstream_nems.sh
+++ b/ush/fv3gfs_downstream_nems.sh
@@ -99,7 +99,7 @@ fi
#-----------------------------------------------------
#-----------------------------------------------------
-if [ $machine = WCOSS -o $machine = WCOSS_C -o $machine = WCOSS_DELL_P3 -o $machine = HERA -o $machine = ORION -o $machine = JET -o $machine = S4 ]; then
+if [ $machine = WCOSS -o $machine = WCOSS_C -o $machine = WCOSS_DELL_P3 -o $machine = HERA -o $machine = ORION -o $machine = JET -o $machine = S4 -o $machine = WCOSS2 ]; then
#-----------------------------------------------------
#-----------------------------------------------------
export nset=1
@@ -171,7 +171,7 @@ date
export MP_PGMMODEL=mpmd
export MP_CMDFILE=$DATA/poescript
launcher=${APRUN_DWN:-"aprun -j 1 -n 24 -N 24 -d 1 cfp"}
- if [ $machine = WCOSS_C -o $machine = WCOSS_DELL_P3 ] ; then
+ if [ $machine = WCOSS_C -o $machine = WCOSS_DELL_P3 -o $machine = WCOSS2 ] ; then
$launcher $MP_CMDFILE
elif [ $machine = HERA -o $machine = ORION -o $machine = JET -o $machine = S4 ] ; then
if [ -s $DATA/poescript_srun ]; then rm -f $DATA/poescript_srun; fi
diff --git a/ush/gfs_nceppost.sh b/ush/gfs_nceppost.sh
index 975bdc6a6..2ee5afcde 100755
--- a/ush/gfs_nceppost.sh
+++ b/ush/gfs_nceppost.sh
@@ -23,6 +23,8 @@
# Remove legacy setting for reading non-nemsio model output
# and generating grib1 data
# 2019-06-02 Wen Meng: Remove the links of gfs fix files.
+# 2021-06-11 Yali Mao: Instead of err_chk, 'exit $err' for wafsfile
+# if POSTGPEXEC fails
#
# Usage: global_postgp.sh SIGINP FLXINP FLXIOUT PGBOUT PGIOUT IGEN
#
@@ -292,7 +294,7 @@ export pgm=$PGM
$LOGSCRIPT
cat <postgp.inp.nml$$
&NAMPGB
- $POSTGPVARS
+ $POSTGPVARS numx=2
EOF
cat <>postgp.inp.nml$$
@@ -351,6 +353,12 @@ ${APRUN:-mpirun.lsf} $POSTGPEXEC < itag > outpost_gfs_${VDATE}_${CTL}
export ERR=$?
export err=$ERR
+
+if [ $err -ne 0 ] ; then
+ if [ $PGBOUT = "wafsfile" ] ; then
+ exit $err
+ fi
+fi
$ERRSCRIPT||exit 2
if [ $FILTER = "1" ] ; then