Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

solve_nmm.F @ 3094

Last change on this file since 3094 was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 95.8 KB

Rev	Line
[2759]	1	!-----------------------------------------------------------------------
	2	!
	3	!NCEP_MESO:MEDIATION_LAYER:SOLVER
	4	!
	5	!-----------------------------------------------------------------------
	6	#include "nmm_loop_basemacros.h"
	7	#include "nmm_loop_macros.h"
	8	!-----------------------------------------------------------------------
	9	!
	10	SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS &
	11	!
	12	#include "dummy_args.inc"
	13	!
	14	& )
	15	!-----------------------------------------------------------------------
	16	USE MODULE_DOMAIN, ONLY : DOMAIN, GET_IJK_FROM_GRID
	17	USE MODULE_CONFIGURE, ONLY : GRID_CONFIG_REC_TYPE
	18	USE MODULE_MODEL_CONSTANTS
	19	USE MODULE_STATE_DESCRIPTION
	20	USE MODULE_CTLBLK
	21	!#ifdef DM_PARALLEL
	22	! USE MODULE_DM
	23	!#endif
	24	USE MODULE_IGWAVE_ADJUST, ONLY: PDTE,PFDHT,DDAMP,VTOA
	25	USE MODULE_ADVECTION, ONLY: ADVE,VAD2,HAD2,VAD2_SCAL,HAD2_SCAL
	26	USE MODULE_NONHY_DYNAM, ONLY: EPS,VADZ,HADZ
	27	USE MODULE_DIFFUSION_NMM, ONLY: HDIFF
	28	USE MODULE_BNDRY_COND, ONLY: BOCOH,BOCOV
	29	USE MODULE_PHYSICS_CALLS
	30	USE MODULE_EXT_INTERNAL
	31	USE MODULE_PRECIP_ADJUST
	32	USE MODULE_NEST_UTIL ! USEs module_MPP (contains MYPE,NPES,MPI_COMM_COMP)
	33	#ifdef WRF_CHEM
	34	USE MODULE_INPUT_CHEM_DATA, ONLY: GET_LAST_GAS
	35	#endif
	36	!-----------------------------------------------------------------------
	37	!
	38	IMPLICIT NONE
	39	!
	40	!-----------------------------------------------------------------------
	41	!
	42	!*** INPUT DATA
	43	!
	44	!-----------------------------------------------------------------------
	45	!
	46	TYPE(DOMAIN),TARGET :: GRID
	47	!
	48	!*** DEFINITIONS OF DUMMY ARGUMENTS TO THIS ROUTINE (GENERATED FROM REGISTRY)
	49	!
	50	! NOTE, REGISTRY NO LONGER GENERATES DUMMY ARGUMENTS OR DUMMY ARGUMENT
	51	! DECLARATIONS FOR RCONFIG ENTRIES. THEY ARE STILL PART OF STATE. ACCESS
	52	! TO THESE VARIABLES IS NOW THROUGH GRID STRUCTURE, AS MODIFIED BELOW.
	53	! AFFECTED VARIABLES: SIGMA, DT, NPHS, IDTAD, NRADS, NRADL, JULDAY,
	54	! JULYR, NUM_SOIL_LAYERS, NCNVC, ENSDIM, DY, AND SPEC_BDY_WIDTH.
	55	! JM, 20050819
	56	!
	57	!----------------------------
	58	#include <dummy_decl.inc>
	59	!----------------------------
	60	!
	61	!*** STRUCTURE THAT CONTAINS RUN-TIME CONFIGURATION (NAMELIST) DATA FOR DOMAIN
	62	!
	63	TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
	64	#ifdef WRF_CHEM
	65	INTEGER :: NUMGAS
	66	#endif
	67	!
	68	!-----------------------------------------------------------------------
	69	!
	70	!*** LOCAL VARIABLES
	71	!
	72	!-----------------------------------------------------------------------
	73	INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE &
	74	& ,IMS,IME,JMS,JME,KMS,KME &
	75	& ,IPS,IPE,JPS,JPE,KPS,KPE &
	76	& ,ITS,ITE,JTS,JTE,KTS,KTE
	77	!
	78	INTEGER :: I,ICLTEND,IDF,IRTN,J,JC,JDF,K,KDF,LB,N_MOIST &
	79	& ,NTSD_current,L
	80	integer :: ierr
	81	INTEGER,SAVE :: NTSD_restart
	82	! INTEGER :: MPI_COMM_COMP,MYPE,MYPROC,NPES
	83	INTEGER :: MYPROC
	84	INTEGER :: KVH,NTSD_rad,RC
	85	INTEGER :: NUM_OZMIXM,NUM_AEROSOLC
	86	!
	87	REAL :: DT_INV,FICE,FRAIN,GPS,QI,QR,QW,WC
	88	!
	89	LOGICAL :: LAST_TIME,OPERATIONAL_PHYSICS
	90	!
	91	CHARACTER(80) :: MESSAGE
	92	!
	93	!*** For precip assimilation:
	94	INTEGER :: ISTAT
	95	REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: PPTDAT
	96	#ifdef WRF_CHEM
	97	REAL,ALLOCATABLE,DIMENSION(:,:,:,:) :: CHEM_TRANS
	98	#endif
	99	!
	100	!-----------------------------------------------------------------------
	101	!*** For physics compatibility with other packages
	102	!-----------------------------------------------------------------------
	103	!
	104	REAL,ALLOCATABLE,DIMENSION(:,:,:) :: TTEN,QTEN
	105	REAL,ALLOCATABLE,DIMENSION(:,:,:) :: RTHRATEN,RTHBLTEN,RQVBLTEN
	106	!
	107	!-----------------------------------------------------------------------
	108	!
	109	LOGICAL wrf_dm_on_monitor
	110	EXTERNAL wrf_dm_on_monitor
	111	!
	112	!-----------------------------------------------------------------------
	113	!*** TIMING VARIABLES
	114	!-----------------------------------------------------------------------
	115	real,save :: solve_tim,exch_tim,pdte_tim,adve_tim,vtoa_tim &
	116	&, vadz_tim,hadz_tim,eps_tim,vad2_tim,had2_tim &
	117	&, radiation_tim,rdtemp_tim,turbl_tim,cltend_tim &
	118	&, cucnvc_tim,gsmdrive_tim,hdiff_tim,bocoh_tim &
	119	&, pfdht_tim,ddamp_tim,bocov_tim,uv_htov_tim,sum_tim &
	120	&, adjppt_tim
	121	real,save :: exch_tim_max
	122	real :: btim,btimx
	123	real :: et_max,this_tim
	124	integer :: n_print_time
	125	!
	126	#ifdef RSL
	127	integer rsl_internal_milliclock
	128	external rsl_internal_milliclock
	129	# define timef rsl_internal_milliclock
	130	#else
	131	real*8 :: timef
	132	#endif
	133	!-----------------------------------------------------------------------
	134	!
	135	#ifdef DEREF_KLUDGE
	136	! SEE http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
	137	INTEGER :: SM31,EM31,SM32,EM32,SM33,EM33
	138	INTEGER :: SM31X,EM31X,SM32X,EM32X,SM33X,EM33X
	139	INTEGER :: SM31Y,EM31Y,SM32Y,EM32Y,SM33Y,EM33Y
	140	#endif
	141	!
	142	!-----------------------------------------------------------------------
	143	!
	144	! LIMIT THE NUMBER OF ARGUMENTS IF COMPILED WITH -DLIMIT_ARGS BY COPYING
	145	! SCALAR (NON-ARRAY) ARGUMENTS OUT OF THE GRID DATA STRUCTURE INTO LOCALLY
	146	! DEFINED COPIES (DEFINED IN EM_DUMMY_DECL.INC, ABOVE, AS THEY ARE IF THEY
	147	! ARE ARGUMENTS). AN EQUIVALENT INCLUDE OF EM_SCALAR_DEREFS.INC APPEARS
	148	! AT THE END OF THE ROUTINE TO COPY BACK ANY CHNAGED NON-ARRAY VALUES.
	149	! THE DEFINITION OF COPY_IN OR COPY_OUT BEFORE THE INCLUDE DEFINES THE
	150	! DIRECTION OF THE COPY. NMM_SCALAR_DEREFS IS GENERATED FROM REGISTRY.
	151	!
	152	!-----------------------------------------------------------------------
	153	#define COPY_IN
	154	#include <scalar_derefs.inc>
	155	!-----------------------------------------------------------------------
	156	!
	157	! TRICK PROBLEMATIC COMPILERS INTO NOT PERFORMING COPY-IN/COPY-OUT BY ADDING
	158	! INDICES TO ARRAY ARGUMENTS IN THE CALL STATEMENTS IN THIS ROUTINE.
	159	! IT HAS THE EFFECT OF PASSING ONLY THE FIRST ELEMENT OF THE ARRAY, RATHER
	160	! THAN THE ENTIRE ARRAY. SEE:
	161	! http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
	162	!
	163	!-----------------------------------------------------------------------
	164	#include "deref_kludge.h"
	165	!-----------------------------------------------------------------------
	166	!
	167	! NEEDED BY SOME COMM LAYERS, E.G. RSL. IF NEEDED, nmm_data_calls.inc IS
	168	! GENERATED FROM THE REGISTRY. THE DEFINITION OF REGISTER_I1 ALLOWS
	169	! I1 DATA TO BE COMMUNICATED IN THIS ROUTINE IF NECESSARY.
	170	!
	171	!-----------------------------------------------------------------------
	172	!-----------------------------------------------------------------------
	173	!***********************************************************************
	174	!***
	175	!*** THE MAIN TIME INTEGRATION LOOP
	176	!***
	177	!-----------------------------------------------------------------------
	178	!
	179	!*** NTSD IS THE TIMESTEP COUNTER (Number of Time Steps Done)
	180	!
	181	!-----------------------------------------------------------------------
	182	!***
	183	!*** ADVANCE_count STARTS AT ZERO FOR ALL RUNS (REGULAR AND RESTART).
	184	!***
	185	!-----------------------------------------------------------------------
	186	!
	187	CALL DOMAIN_CLOCK_GET(GRID,ADVANCEcOUNT=NTSD_current)
	188	!
	189	IF(NTSD_current==0)THEN
	190	IF(GRID%RESTART.AND.GRID%TSTART>0.)THEN
	191	IHRST=NSTART_HOUR
	192	NTSD_restart=NTSD
	193	ELSE
	194	IHRST=GRID%GMT
	195	NSTART_HOUR=IHRST
	196	NTSD_restart=0
	197	ENDIF
	198	ENDIF
	199	!
	200	NTSD=NTSD_restart+NTSD_current
	201	LAST_TIME=domain_last_time_step(GRID)
	202	!
	203	!-----------------------------------------------------------------------
	204	!
	205	!!!!! IF(WRF_DM_ON_MONITOR() )THEN
	206	WRITE(MESSAGE,125)NTSD,NTSD*GRID%DT/3600.
	207	125 FORMAT(' SOLVE_NMM: TIMESTEP IS ',I5,' TIME IS ',F7.3,' HOURS')
	208	CALL WRF_MESSAGE(TRIM(MESSAGE))
	209	!!!! ENDIF
	210	!
	211	!-----------------------------------------------------------------------
	212	CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
	213	CALL WRF_GET_NPROC(NPES)
	214	CALL WRF_GET_MYPROC(MYPROC)
	215	MYPE=MYPROC
	216	!-----------------------------------------------------------------------
	217	!
	218	!*** OBTAIN DIMENSION INFORMATION STORED IN THE GRID DATA STRUCTURE.
	219	!
	220	CALL GET_IJK_FROM_GRID(GRID &
	221	& ,IDS,IDE,JDS,JDE,KDS,KDE &
	222	& ,IMS,IME,JMS,JME,KMS,KME &
	223	& ,IPS,IPE,JPS,JPE,KPS,KPE )
	224	!-----------------------------------------------------------------------
	225	!
	226	!*** COMPUTE THESE STARTING AND STOPPING LOCATIONS FOR EACH TILE AND
	227	!*** NUMBER OF TILES.
	228	!*** SEE: http://www.mmm.ucar.edu/wrf/WG2/topics/settiles
	229	!
	230	CALL SET_TILES(GRID,IDS,IDE,JDS,JDE,IPS,IPE,JPS,JPE)
	231	!
	232	!-----------------------------------------------------------------------
	233	!*** SET FLAG FOR THE OPERATIONAL PHYSICS SUITE.
	234	!*** THIS WILL BE USED TO SAVE CLOCKTIME BY SKIPPING
	235	!*** FREQUENT UPDATES OF THE MOIST ARRAY AND INSTEAD
	236	!*** UPDATE IT ONLY WHEN IT IS NEEDED FOR PHYSICS.
	237	!-----------------------------------------------------------------------
	238	!
	239	OPERATIONAL_PHYSICS=.FALSE.
	240	!
	241	IF(CONFIG_FLAGS%RA_SW_PHYSICS ==GFDLSWSCHEME.AND. &
	242	& CONFIG_FLAGS%RA_LW_PHYSICS ==GFDLLWSCHEME.AND. &
	243	& CONFIG_FLAGS%SF_SFCLAY_PHYSICS==MYJSFCSCHEME.AND. &
	244	& CONFIG_FLAGS%BL_PBL_PHYSICS ==MYJPBLSCHEME.AND. &
	245	& CONFIG_FLAGS%CU_PHYSICS ==BMJSCHEME.AND. &
	246	& CONFIG_FLAGS%MP_PHYSICS ==ETAMPNEW)THEN
	247	!
	248	OPERATIONAL_PHYSICS=.TRUE.
	249	!
	250	ENDIF
	251	!
	252	!-----------------------------------------------------------------------
	253	!
	254	!*** TTEN, QTEN are used by GD convection scheme
	255	!
	256	ALLOCATE(TTEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT)
	257	ALLOCATE(QTEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT)
	258	ALLOCATE(RTHBLTEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT)
	259	ALLOCATE(RQVBLTEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT)
	260	ALLOCATE(RTHRATEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT)
	261	#ifdef WRF_CHEM
	262	ALLOCATE(CHEM_TRANS(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT)
	263	NUMGAS = GET_LAST_GAS(CONFIG_FLAGS%CHEM_OPT)
	264	#endif
	265	!
	266	IF(CONFIG_FLAGS%CU_PHYSICS==GDSCHEME)THEN
	267	DO J=JMS,JME
	268	DO K=KMS,KME
	269	DO I=IMS,IME
	270	TTEN(I,K,J)=T(I,J,K)
	271	QTEN(I,K,J)=Q(I,J,K)
	272	ENDDO
	273	ENDDO
	274	ENDDO
	275	ENDIF
	276	!
	277	GRID%SIGMA=1
	278	HYDRO=.FALSE.
	279	!
	280	!
	281	IDF=IDE-1
	282	JDF=JDE-1
	283	KDF=KDE-1
	284	!
	285	!-----------------------------------------------------------------------
	286	!
	287	!*** FOR NOW SET CONTROLS FOR TILES TO PATCHES
	288	!
	289	!-----------------------------------------------------------------------
	290	ITS=IPS
	291	ITE=MIN(IPE,IDF)
	292	JTS=JPS
	293	JTE=MIN(JPE,JDF)
	294	KTS=KPS
	295	KTE=MIN(KPE,KDF)
	296	if(ntsd==0)then
	297	write(0,*)' its=',its,' ite=',ite
	298	write(0,*)' jts=',jts,' jte=',jte
	299	write(0,*)' kts=',kts,' kte=',kte
	300	endif
	301	!-----------------------------------------------------------------------
	302	!*** SET TIMING VARIABLES TO ZERO AT START OF FORECAST.
	303	!-----------------------------------------------------------------------
	304	if(ntsd==0)then
	305	solve_tim=0.
	306	exch_tim=0.
	307	pdte_tim=0.
	308	adve_tim=0.
	309	vtoa_tim=0.
	310	vadz_tim=0.
	311	hadz_tim=0.
	312	eps_tim=0.
	313	vad2_tim=0.
	314	had2_tim=0.
	315	radiation_tim=0.
	316	rdtemp_tim=0.
	317	turbl_tim=0.
	318	cltend_tim=0.
	319	cucnvc_tim=0.
	320	gsmdrive_tim=0.
	321	hdiff_tim=0.
	322	bocoh_tim=0.
	323	pfdht_tim=0.
	324	ddamp_tim=0.
	325	bocov_tim=0.
	326	uv_htov_tim=0.
	327	exch_tim_max=0.
	328	adjppt_tim=0.
	329	endif
	330	!-----------------------------------------------------------------------
	331	N_MOIST=NUM_MOIST
	332	!
	333	DO J=MYJS_P4,MYJE_P4
	334	IHEG(J)=MOD(J+1,2)
	335	IHWG(J)=IHEG(J)-1
	336	IVEG(J)=MOD(J,2)
	337	IVWG(J)=IVEG(J)-1
	338	ENDDO
	339
	340	DO J=MYJS_P4,MYJE_P4
	341	IVW(J)=IVWG(J)
	342	IVE(J)=IVEG(J)
	343	IHE(J)=IHEG(J)
	344	IHW(J)=IHWG(J)
	345	ENDDO
	346	!
	347	!*** LATERAL POINTS IN THE BOUNDARY ARRAYS
	348	!
	349	LB=2*(IDF-IDS+1)+(JDF-JDS+1)-3
	350	!
	351	!*** APPROXIMATE GRIDPOINT SPACING (METERS)
	352	!
	353	JC=JMS+(JME-JMS)/2
	354	GPS=SQRT(DX_NMM(IMS,JC)2+DY_NMM2)
	355	!
	356	!*** TIMESTEPS PER HOUR
	357	!
	358	TSPH=3600./GRID%DT
	359	!
	360	n_print_time=nint(3600./grid%dt) ! Print stats once per hour
	361	!-----------------------------------------------------------------------
	362	!
	363	NBOCO=0
	364	!
	365	!-----------------------------------------------------------------------
	366	!
	367	#if (NMM_NEST == 1)
	368	!-----------------------------------------------------------------------------
	369	!*** PATCHING NESTED BOUNDARIES.
	370	!-----------------------------------------------------------------------------
	371	!
	372	CALL wrf_debug ( 100 , 'nmm: in patch' )
	373
	374	btimx=timef()
	375	#ifdef DM_PARALLEL
	376	# include "HALO_NMM_ZZ.inc"
	377	#endif
	378
	379	IF(GRID%ID/=1)THEN
	380	!
	381	CALL NESTBC_PATCH (PD_BXS,PD_BXE,PD_BYS,PD_BYE,T_BXS,T_BXE,T_BYS,T_BYE,Q_BXS,Q_BXE &
	382	,Q_BYS,Q_BYE,U_BXS,U_BXE,U_BYS,U_BYE,V_BXS,V_BXE,V_BYS,V_BYE &
	383	,Q2_BXS,Q2_BXE,Q2_BYS,Q2_BYE,CWM_BXS,CWM_BXE,CWM_BYS,CWM_BYE &
	384	,PD_BTXS,PD_BTXE,PD_BTYS,PD_BTYE,T_BTXS,T_BTXE,T_BTYS,T_BTYE &
	385	,Q_BTXS,Q_BTXE,Q_BTYS,Q_BTYE,U_BTXS,U_BTXE,U_BTYS,U_BTYE &
	386	,V_BTXS,V_BTXE,V_BTYS,V_BTYE,Q2_BTXS,Q2_BTXE,Q2_BTYS,Q2_BTYE &
	387	,CWM_BTXS,CWM_BTXE,CWM_BTYS,CWM_BTYE,PDNEST_B,TNEST_B,QNEST_B,UNEST_B &
	388	,VNEST_B,Q2NEST_B,CWMNEST_B,PDNEST_BT,TNEST_BT,QNEST_BT &
	389	,UNEST_BT,VNEST_BT,Q2NEST_BT,CWMNEST_BT &
	390	,GRID%SPEC_BDY_WIDTH &
	391	,IDS,IDF,JDS,JDF,KDS,KDE &
	392	,IMS,IME,JMS,JME,KMS,KME &
	393	,ITS,ITE,JTS,JTE,KTS,KTE )
	394
	395	CALL wrf_debug ( 100 , 'nmm: out of patch' )
	396	!
	397	#ifdef MOVE_NESTS
	398
	399	IF(GRID%ID/=1.AND.MOD(NTSD,1)==0.AND.GRID%NUM_MOVES==-99)THEN
	400	XLOC_1=(IDE-1)/2 ! This maneuvers the storm to the center of the nest quickly
	401	YLOC_1=(JDE-1)/2 ! This maneuvers the storm to the center of the nest quickly
	402	ENDIF
	403	#endif
	404
	405	ENDIF
	406	#endif
	407	!
	408	!-----------------------------------------------------------------------
	409	!*** ALLOCATE PPTDAT ARRAY (PRECIP ASSIM):
	410	!-----------------------------------------------------------------------
	411	!
	412	IF(GRID%PCPFLG.AND..NOT.ALLOCATED(PPTDAT))THEN
	413	ALLOCATE(PPTDAT(IMS:IME,JMS:JME,3),STAT=ISTAT)
	414	ENDIF
	415	!
	416	!-----------------------------------------------------------------------
	417	!***
	418	!*** Call READPCP to
	419	!*** 1) READ IN PRECIPITATION FOR HOURS 1, 2 and 3;
	420	!*** 2) Initialize DDATA to 999. (this is the amount
	421	!*** of input precip allocated to each physics time step
	422	!*** in ADJPPT; TURBL/SURFCE, which uses DDATA, is called
	423	!*** before ADJPPT)
	424	!*** 3) Initialize LSPA to zero
	425	!***
	426	!-----------------------------------------------------------------------
	427	IF (NTSD==0) THEN
	428	IF (GRID%PCPFLG) THEN
	429	CALL READPCP(PPTDAT,DDATA,LSPA &
	430	& ,IDS,IDE,JDS,JDE,KDS,KDE &
	431	& ,IMS,IME,JMS,JME,KMS,KME &
	432	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	433	ENDIF
	434	ENDIF
	435	!-----------------------------------------------------------------------
	436	!
	437	btim=timef()
	438	!
	439	!-----------------------------------------------------------------------
	440	!*** ZERO OUT ACCUMULATED QUANTITIES WHEN NEEDED.
	441	!-----------------------------------------------------------------------
	442	!
	443	CALL BUCKETS(NTSD,NPREC,NSRFC,NRDSW,NRDLW &
	444	& ,GRID%RESTART,GRID%TSTART &
	445	& ,NCLOD,NHEAT,GRID%NPHS,TSPH &
	446	& ,ACPREC,CUPREC,ACSNOW,ACSNOM,SSROFF,BGROFF &
	447	& ,SFCEVP,POTEVP,SFCSHX,SFCLHX,SUBSHX,SNOPCX &
	448	& ,SFCUVX,POTFLX &
	449	& ,ARDSW,ASWIN,ASWOUT,ASWTOA &
	450	& ,ARDLW,ALWIN,ALWOUT,ALWTOA &
	451	& ,ACFRST,NCFRST,ACFRCV,NCFRCV &
	452	& ,AVCNVC,AVRAIN,TCUCN,TRAIN &
	453	& ,ASRFC &
	454	& ,T,TLMAX,TLMIN,TSHLTR,PSHLTR,QSHLTR &
	455	& ,T02_MAX,T02_MIN,RH02_MAX,RH02_MIN &
	456	& ,IDS,IDE,JDS,JDE,KDS,KDE &
	457	& ,IMS,IME,JMS,JME,KMS,KME &
	458	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	459	!-----------------------------------------------------------------------
	460	!
	461	IF(NTSD==0)THEN
	462	FIRST=.TRUE.
	463	! call hpm_init()
	464	btimx=timef()
	465	!
	466	!-----------------------------------------------------------------------
	467	#ifdef DM_PARALLEL
	468	# include "HALO_NMM_A.inc"
	469	#endif
	470	!
	471	!-----------------------------------------------------------------------
	472	#ifdef DM_PARALLEL
	473	IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW)THEN
	474	# include "HALO_NMM_A_3.inc"
	475	ENDIF
	476	#endif
	477	!-----------------------------------------------------------------------
	478	!
	479	!*** Only for chemistry:
	480	!
	481	#ifdef WRF_CHEM
	482	#ifdef DM_PARALLEL
	483	# include "HALO_NMM_A_2.inc"
	484	#endif
	485	#endif
	486	!
	487	!-----------------------------------------------------------------------
	488	!*** USE THE FOLLOWING VARIABLES TO KEEP TRACK OF EXCHANGE TIMES.
	489	!-----------------------------------------------------------------------
	490	exch_tim=exch_tim+timef()-btimx
	491	! this_tim=timef()-btimx
	492	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	493	! & ,mpi_comm_comp,irtn)
	494	! exch_tim_max=exch_tim_max+et_max
	495	!-----------------------------------------------------------------------
	496	!
	497	GO TO 2003
	498	ENDIF
	499	!
	500	!-----------------------------------------------------------------------
	501	!-----------------------------------------------------------------------
	502	2000 CONTINUE
	503	!-----------------------------------------------------------------------
	504	!-----------------------------------------------------------------------
	505	!
	506	!-----------------------------------------------------------------------
	507	!*** PRESSURE TENDENCY, SIGMA DOT, VERTICAL PART OF OMEGA-ALPHA
	508	!-----------------------------------------------------------------------
	509	!
	510	btimx=timef()
	511	!-----------------
	512	#ifdef DM_PARALLEL
	513	# include "HALO_NMM_D.inc"
	514	#endif
	515	!-----------------
	516	exch_tim=exch_tim+timef()-btimx
	517	! this_tim=timef()-btimx
	518	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	519	! & ,mpi_comm_comp,irtn)
	520	! exch_tim_max=exch_tim_max+et_max
	521	!
	522	btimx=timef()
	523	!
	524	CALL PDTE( &
	525	#ifdef DM_PARALLEL
	526	& GRID,MYPE,MPI_COMM_COMP, &
	527	#endif
	528	& NTSD,GRID%DT,PT,ETA2,RES,HYDRO,HBM2 &
	529	& ,PD,PDSL,PDSLO &
	530	& ,PETDT,DIV,PSDT &
	531	& ,IHE,IHW,IVE,IVW &
	532	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	533	& ,IMS,IME,JMS,JME,KMS,KME &
	534	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	535
	536	pdte_tim=pdte_tim+timef()-btimx
	537	!
	538	!-----------------------------------------------------------------------
	539	!*** ADVECTION OF T, U, AND V
	540	!-----------------------------------------------------------------------
	541	!
	542	btimx=timef()
	543	!-----------------
	544	#ifdef DM_PARALLEL
	545	# include "HALO_NMM_F.inc"
	546	# include "HALO_NMM_F1.inc"
	547	#endif
	548	!-----------------
	549	exch_tim=exch_tim+timef()-btimx
	550	! this_tim=timef()-btimx
	551	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	552	! & ,mpi_comm_comp,irtn)
	553	! exch_tim_max=exch_tim_max+et_max
	554	btimx=timef()
	555	!
	556	CALL ADVE(NTSD,GRID%DT,DETA1,DETA2,PDTOP &
	557	& ,CURV,F,FAD,F4D,EM_LOC,EMT_LOC,EN,ENT,DX_NMM,DY_NMM &
	558	& ,HBM2,VBM2 &
	559	& ,T,U,V,PDSLO,TOLD,UOLD,VOLD &
	560	& ,PETDT,UPSTRM &
	561	& ,FEW,FNS,FNE,FSE &
	562	& ,ADT,ADU,ADV &
	563	& ,N_IUP_H,N_IUP_V &
	564	& ,N_IUP_ADH,N_IUP_ADV &
	565	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
	566	& ,IHE,IHW,IVE,IVW &
	567	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	568	& ,IMS,IME,JMS,JME,KMS,KME &
	569	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	570	!
	571	adve_tim=adve_tim+timef()-btimx
	572	!
	573	!-----------------------------------------------------------------------
	574	!*** PRESSURE TENDENCY, ETA/SIGMADOT, VERTICAL PART OF OMEGA-ALPHA TERM
	575	!-----------------------------------------------------------------------
	576	!
	577	btimx=timef()
	578	!
	579	CALL VTOA( &
	580	#ifdef DM_PARALLEL
	581	& GRID, &
	582	#endif
	583	& NTSD,GRID%DT,PT,ETA2 &
	584	& ,HBM2,EF4T &
	585	& ,T,DWDT,RTOP,OMGALF &
	586	& ,PINT,DIV,PSDT,RES &
	587	& ,IHE,IHW,IVE,IVW &
	588	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	589	& ,IMS,IME,JMS,JME,KMS,KME &
	590	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	591	!
	592	vtoa_tim=vtoa_tim+timef()-btimx
	593	!
	594	!-----------------------------------------------------------------------
	595	!*** VERTICAL ADVECTION OF HEIGHT
	596	!-----------------------------------------------------------------------
	597	!
	598	btimx=timef()
	599	!
	600	CALL VADZ(NTSD,GRID%DT,FIS,GRID%SIGMA,DFL,HBM2 &
	601	& ,DETA1,DETA2,PDTOP &
	602	& ,PINT,PDSL,PDSLO,PETDT &
	603	& ,RTOP,T,Q,CWM,Z,W,DWDT,PDWDT &
	604	& ,IHE,IHW,IVE,IVW &
	605	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	606	& ,IMS,IME,JMS,JME,KMS,KME &
	607	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	608
	609	vadz_tim=vadz_tim+timef()-btimx
	610	!
	611	!-----------------------------------------------------------------------
	612	!*** HORIZONTAL ADVECTION OF HEIGHT
	613	!-----------------------------------------------------------------------
	614	!
	615	btimx=timef()
	616	!-----------------
	617	#ifdef DM_PARALLEL
	618	# include "HALO_NMM_G.inc"
	619	#endif
	620	!-----------------
	621	exch_tim=exch_tim+timef()-btimx
	622	! this_tim=timef()-btimx
	623	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	624	! & ,mpi_comm_comp,irtn)
	625	! exch_tim_max=exch_tim_max+et_max
	626	!
	627	btimx=timef()
	628	!
	629	CALL HADZ(NTSD,GRID%DT,HYDRO,HBM2,DETA1,DETA2,PDTOP &
	630	& ,DX_NMM,DY_NMM,FAD &
	631	& ,FEW,FNS,FNE,FSE &
	632	& ,PDSL,U,V,W,Z &
	633	& ,IHE,IHW,IVE,IVW &
	634	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	635	& ,IMS,IME,JMS,JME,KMS,KME &
	636	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	637	!
	638	hadz_tim=hadz_tim+timef()-btimx
	639	!
	640	!-----------------------------------------------------------------------
	641	!*** ADVECTION OF W
	642	!-----------------------------------------------------------------------
	643	!
	644	btimx=timef()
	645	!-----------------
	646	#ifdef DM_PARALLEL
	647	# include "HALO_NMM_H.inc"
	648	#endif
	649	!-----------------
	650	exch_tim=exch_tim+timef()-btimx
	651	! this_tim=timef()-btimx
	652	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	653	! & ,mpi_comm_comp,irtn)
	654	! exch_tim_max=exch_tim_max+et_max
	655	!
	656	btimx=timef()
	657	!
	658	CALL EPS(NTSD,GRID%DT,HYDRO,DX_NMM,DY_NMM,FAD &
	659	& ,DETA1,DETA2,PDTOP,PT &
	660	& ,HBM2,HBM3 &
	661	& ,PDSL,PDSLO,PINT,RTOP,PETDT,PDWDT &
	662	& ,DWDT,DWDTMN,DWDTMX &
	663	& ,FNS,FEW,FNE,FSE &
	664	& ,T,U,V,W,Q,CWM &
	665	& ,IHE,IHW,IVE,IVW &
	666	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	667	& ,IMS,IME,JMS,JME,KMS,KME &
	668	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	669	!
	670	eps_tim=eps_tim+timef()-btimx
	671	!
	672	!-----------------------------------------------------------------------
	673	!*** VERTICAL ADVECTION OF Q, TKE, AND CLOUD WATER
	674	!-----------------------------------------------------------------------
	675	!
	676	IF(MOD(NTSD,GRID%IDTAD)==0)THEN
	677	btimx=timef()
	678	!
	679	vad2_micro_check: IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)THEN
	680	CALL VAD2(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM &
	681	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP,HBM2 &
	682	& ,Q,Q2,CWM,PETDT &
	683	& ,N_IUP_H,N_IUP_V &
	684	& ,N_IUP_ADH,N_IUP_ADV &
	685	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
	686	& ,IHE,IHW,IVE,IVW &
	687	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	688	& ,IMS,IME,JMS,JME,KMS,KME &
	689	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	690	!
	691	ELSE vad2_micro_check
	692	CALL VAD2_SCAL(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM &
	693	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
	694	& ,HBM2 &
	695	& ,Q2,PETDT &
	696	& ,N_IUP_H,N_IUP_V &
	697	& ,N_IUP_ADH,N_IUP_ADV &
	698	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
	699	& ,IHE,IHW,IVE,IVW &
	700	& ,1,1 &
	701	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	702	& ,IMS,IME,JMS,JME,KMS,KME &
	703	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	704
	705	CALL VAD2_SCAL(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM &
	706	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
	707	& ,HBM2 &
	708	& ,MOIST,PETDT &
	709	& ,N_IUP_H,N_IUP_V &
	710	& ,N_IUP_ADH,N_IUP_ADV &
	711	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
	712	& ,IHE,IHW,IVE,IVW &
	713	& ,NUM_MOIST,2 &
	714	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	715	& ,IMS,IME,JMS,JME,KMS,KME &
	716	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	717	!
	718	CALL VAD2_SCAL(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM &
	719	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
	720	& ,HBM2 &
	721	& ,SCALAR,PETDT &
	722	& ,N_IUP_H,N_IUP_V &
	723	& ,N_IUP_ADH,N_IUP_ADV &
	724	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
	725	& ,IHE,IHW,IVE,IVW &
	726	& ,NUM_SCALAR,2 &
	727	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	728	& ,IMS,IME,JMS,JME,KMS,KME &
	729	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	730	!
	731
	732	DO K=KTS,KTE
	733	DO J=MYJS,MYJE
	734	DO I=MYIS,MYIE
	735	Q(I,J,K)=MOIST(I,J,K,P_QV)/(1.+MOIST(I,J,K,P_QV))
	736	ENDDO
	737	ENDDO
	738	ENDDO
	739	!
	740	ENDIF vad2_micro_check
	741	!
	742	vad2_tim=vad2_tim+timef()-btimx
	743	!
	744	ENDIF
	745	!
	746	!-----------------------------------------------------------------------
	747	!*** VERTICAL ADVECTION OF CHEMISTRY
	748	!-----------------------------------------------------------------------
	749	!
	750	#ifdef WRF_CHEM
	751	IF(MOD(NTSD,GRID%IDTAD)==0)THEN
	752	#ifdef IBM
	753	btimx=timef()
	754	#endif
	755	!
	756	DO L=1,NUM_CHEM
	757	DO K=KMS,KME
	758	DO J=JMS,JME
	759	DO I=IMS,IME
	760	CHEM_TRANS(I,J,K,L)=CHEM(I,K,J,L)
	761	ENDDO
	762	ENDDO
	763	ENDDO
	764	ENDDO
	765
	766
	767	CALL VAD2_SCAL(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM &
	768	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
	769	& ,HBM2 &
	770	& ,CHEM_TRANS,PETDT &
	771	& ,N_IUP_H,N_IUP_V &
	772	& ,N_IUP_ADH,N_IUP_ADV &
	773	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
	774	& ,IHE,IHW,IVE,IVW &
	775	& ,NUM_CHEM,1 &
	776	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	777	& ,IMS,IME,JMS,JME,KMS,KME &
	778	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	779	!
	780	ENDIF
	781	#endif
	782	!
	783	!-----------------------------------------------------------------------
	784	!*** HORIZONTAL ADVECTION OF Q, TKE, AND CLOUD WATER
	785	!-----------------------------------------------------------------------
	786	!
	787	IF(MOD(NTSD,GRID%IDTAD)==0)THEN
	788	btimx=timef()
	789	!-----------------
	790	#ifdef DM_PARALLEL
	791	# include "HALO_NMM_I.inc"
	792	#endif
	793	!
	794	#ifdef DM_PARALLEL
	795	IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW)THEN
	796	# include "HALO_NMM_I_3.inc"
	797	ENDIF
	798	#endif
	799	!
	800	!-----------------
	801	exch_tim=exch_tim+timef()-btimx
	802	! this_tim=timef()-btimx
	803	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	804	! & ,mpi_comm_comp,irtn)
	805	! exch_tim_max=exch_tim_max+et_max
	806	!
	807	btimx=timef()
	808	!
	809	!-----------------------------------------------------------------------
	810	had2_micro_check: IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)THEN
	811	!-----------------------------------------------------------------------
	812	!
	813	CALL HAD2( &
	814	#if defined(DM_PARALLEL)
	815	& GRID%DOMDESC, &
	816	#endif
	817	& NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM &
	818	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
	819	& ,HBM2,HBM3 &
	820	& ,Q,Q2,CWM,U,V,Z,HYDRO &
	821	& ,N_IUP_H,N_IUP_V &
	822	& ,N_IUP_ADH,N_IUP_ADV &
	823	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
	824	& ,IHE,IHW,IVE,IVW &
	825	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	826	& ,IMS,IME,JMS,JME,KMS,KME &
	827	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	828	!
	829	!*** UPDATE MOIST ARRAY.
	830	!*** REMEMBER THAT MOIST IS ONLY USED WITH THE PHYSICS AND THUS
	831	!*** THE P_QV SLOT (=2) IS MIXING RATIO, NOT SPECIFIC HUMIDITY.
	832	!*** ALTHOUGH MOIST IS ONLY USED FOR PHYSICS IN OPERATIONS, IT IS
	833	!*** UPDATED HERE FROM Q EVERY ADVECTION TIMESTEP FOR NON-OPERATIONAL
	834	!*** CONFIGURATIONS WHERE IT MAY BE USED OUTSIDE OF THE PHYSICS.
	835	!
	836	IF(.NOT.OPERATIONAL_PHYSICS)THEN
	837	DO K=KTS,KTE
	838	DO J=MYJS,MYJE
	839	DO I=MYIS,MYIE
	840	MOIST(I,J,K,P_QV)=Q(I,J,K)/(1.-Q(I,J,K))
	841	WC = CWM(I,J,K)
	842	QI = 0.
	843	QR = 0.
	844	QW = 0.
	845	FICE=F_ICE(I,K,J)
	846	FRAIN=F_RAIN(I,K,J)
	847	!
	848	IF(FICE>=1.)THEN
	849	QI=WC
	850	ELSEIF(FICE<=0.)THEN
	851	QW=WC
	852	ELSE
	853	QI=FICE*WC
	854	QW=WC-QI
	855	ENDIF
	856	!
	857	IF(QW>0..AND.FRAIN>0.)THEN
	858	IF(FRAIN>=1.)THEN
	859	QR=QW
	860	QW=0.
	861	ELSE
	862	QR=FRAIN*QW
	863	QW=QW-QR
	864	ENDIF
	865	ENDIF
	866	!
	867	MOIST(I,J,K,P_QC)=QW
	868	MOIST(I,J,K,P_QR)=QR
	869	MOIST(I,J,K,P_QI)=0.
	870	MOIST(I,J,K,P_QS)=QI
	871	MOIST(I,J,K,P_QG)=0.
	872	ENDDO
	873	ENDDO
	874	ENDDO
	875	ENDIF
	876	!
	877	!-----------------------------------------------------------------------
	878	ELSE had2_micro_check
	879	!-----------------------------------------------------------------------
	880	!
	881	CALL HAD2_SCAL( &
	882	#if defined(DM_PARALLEL)
	883	& GRID%DOMDESC, &
	884	#endif
	885	& NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM &
	886	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
	887	& ,HBM2,HBM3 &
	888	& ,Q2,U,V,Z,HYDRO &
	889	& ,N_IUP_H,N_IUP_V &
	890	& ,N_IUP_ADH,N_IUP_ADV &
	891	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
	892	& ,IHE,IHW,IVE,IVW &
	893	& ,1,1 &
	894	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	895	& ,IMS,IME,JMS,JME,KMS,KME &
	896	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	897	!
	898	CALL HAD2_SCAL( &
	899	#if defined(DM_PARALLEL)
	900	& GRID%DOMDESC, &
	901	#endif
	902	& NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM &
	903	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
	904	& ,HBM2,HBM3 &
	905	& ,MOIST,U,V,Z,HYDRO &
	906	& ,N_IUP_H,N_IUP_V &
	907	& ,N_IUP_ADH,N_IUP_ADV &
	908	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
	909	& ,IHE,IHW,IVE,IVW &
	910	& ,NUM_MOIST,2 &
	911	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	912	& ,IMS,IME,JMS,JME,KMS,KME &
	913	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	914	!
	915	CALL HAD2_SCAL( &
	916	#if defined(DM_PARALLEL)
	917	& GRID%DOMDESC, &
	918	#endif
	919	& NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM &
	920	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
	921	& ,HBM2,HBM3 &
	922	& ,SCALAR,U,V,Z,HYDRO &
	923	& ,N_IUP_H,N_IUP_V &
	924	& ,N_IUP_ADH,N_IUP_ADV &
	925	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
	926	& ,IHE,IHW,IVE,IVW &
	927	& ,NUM_SCALAR,2 &
	928	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	929	& ,IMS,IME,JMS,JME,KMS,KME &
	930	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	931	!
	932	DO K=KTS,KTE
	933	DO J=MYJS,MYJE
	934	DO I=MYIS,MYIE
	935	Q(I,J,K)=MOIST(I,J,K,P_QV)/(1.+MOIST(I,J,K,P_QV))
	936	ENDDO
	937	ENDDO
	938	ENDDO
	939	!
	940	!-----------------------------------------------------------------------
	941	ENDIF had2_micro_check
	942	!-----------------------------------------------------------------------
	943	!
	944	had2_tim=had2_tim+timef()-btimx
	945	ENDIF
	946	!
	947	!-----------------------------------------------------------------------
	948	!*** HORIZONTAL ADVECTION OF CHEMISTRY
	949	!-----------------------------------------------------------------------
	950	!
	951	#ifdef WRF_CHEM
	952	IF(MOD(NTSD,GRID%IDTAD)==0)THEN
	953	btimx=timef()
	954	#ifdef DM_PARALLEL
	955	# include "HALO_NMM_I_2.inc"
	956	#endif
	957	exch_tim=exch_tim+timef()-btimx
	958	! this_tim=timef()-btimx
	959	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	960	! & ,mpi_comm_comp,irtn)
	961	! exch_tim_max=exch_tim_max+et_max
	962	!
	963	btimx=timef()
	964	!
	965	CALL HAD2_SCAL( &
	966	#if defined(DM_PARALLEL)
	967	& GRID%DOMDESC, &
	968	#endif
	969	& NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM &
	970	& ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP &
	971	& ,HBM2,HBM3 &
	972	& ,CHEM_TRANS,U,V,Z,HYDRO &
	973	& ,N_IUP_H,N_IUP_V &
	974	& ,N_IUP_ADH,N_IUP_ADV &
	975	& ,IUP_H,IUP_V,IUP_ADH,IUP_ADV &
	976	& ,IHE,IHW,IVE,IVW &
	977	& ,NUM_CHEM,1 &
	978	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	979	& ,IMS,IME,JMS,JME,KMS,KME &
	980	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	981
	982	ENDIF
	983	DO L=1,NUM_CHEM
	984	DO J=JMS,JME
	985	DO K=KMS,KME
	986	DO I=IMS,IME
	987	CHEM(I,K,J,L)=CHEM_TRANS(I,J,K,L)
	988	ENDDO
	989	ENDDO
	990	ENDDO
	991	ENDDO
	992	#endif
	993
	994	!
	995	!----------------------------------------------------------------------
	996	!*** RADIATION
	997	!----------------------------------------------------------------------
	998	!
	999	!*** When allocating CAM radiation 4d arrays (ozmixm, aerosolc),
	1000	!*** the following two scalars are not needed.
	1001	!
	1002	NUM_OZMIXM=1
	1003	NUM_AEROSOLC=1
	1004	!
	1005	IF(NTSD<=0)THEN
	1006	NTSD_rad=NTSD
	1007	ELSE
	1008	!
	1009	!*** Call radiation just BEFORE the top of the hour
	1010	!*** so that updated fields are written to history files.
	1011	!
	1012	NTSD_rad=NTSD+1
	1013	ENDIF
	1014	!
	1015	IF(MOD(NTSD_rad,GRID%NRADS)==0.OR. &
	1016	& MOD(NTSD_rad,GRID%NRADL)==0)THEN
	1017	!
	1018	btimx=timef()
	1019	IF(OPERATIONAL_PHYSICS)THEN
	1020	CALL UPDATE_MOIST(MOIST,Q,CWM,F_ICE,F_RAIN,N_MOIST &
	1021	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1022	& ,IMS,IME,JMS,JME,KMS,KME &
	1023	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1024	ENDIF
	1025	!
	1026	CALL RADIATION(NTSD_rad,GRID%DT,GRID%JULDAY,GRID%JULYR &
	1027	& ,GRID%XTIME,GRID%JULIAN &
	1028	& ,IHRST,GRID%NPHS &
	1029	& ,GLAT,GLON,GRID%NRADS,GRID%NRADL &
	1030	& ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2,PDTOP,PT &
	1031	& ,PD,RES,PINT,T,Q,MOIST,THS,ALBEDO,EPSR &
	1032	& ,F_ICE,F_RAIN &
	1033	#ifdef WRF_CHEM
	1034	& ,GD_CLOUD,GD_CLOUD2 &
	1035	#endif
	1036	& ,SM,HBM2,CLDFRA,N_MOIST,RESTRT &
	1037	& ,RLWTT,RSWTT,RLWIN,RSWIN,RSWINC,RSWOUT &
	1038	& ,RLWTOA,RSWTOA,CZMEAN &
	1039	& ,CFRACL,CFRACM,CFRACH,SIGT4 &
	1040	& ,ACFRST,NCFRST,ACFRCV,NCFRCV &
	1041	& ,CUPPT,VEGFRC,SNO,HTOP,HBOT &
	1042	& ,Z,SICE,NUM_AEROSOLC,NUM_OZMIXM &
	1043	& ,GRID,CONFIG_FLAGS &
	1044	& ,RTHRATEN &
	1045	#ifdef WRF_CHEM
	1046	& ,PM2_5_DRY, PM2_5_WATER, PM2_5_DRY_EC &
	1047	& ,TAUAER1, TAUAER2, TAUAER3, TAUAER4 &
	1048	& ,GAER1, GAER2, GAER3, GAER4 &
	1049	& ,WAER1, WAER2, WAER3, WAER4 &
	1050	#endif
	1051	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1052	& ,IMS,IME,JMS,JME,KMS,KME &
	1053	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1054	!
	1055	DO J=JMS,JME
	1056	DO I=IMS,IME
	1057	GSW(I,J)=RSWIN(I,J)-RSWOUT(I,J)
	1058	ENDDO
	1059	ENDDO
	1060	!
	1061	! * NOTE *
	1062	! RLWIN/RSWIN - downward longwave/shortwave at the surface (formerly TOTLWDN/TOTSWDN)
	1063	! RSWINC - CLEAR-SKY downward shortwave at the surface (new for AQ)
	1064	! * NOTE *
	1065	!
	1066	radiation_tim=radiation_tim+timef()-btimx
	1067	ENDIF
	1068	!
	1069	!----------------------------------------------------------------------
	1070	!*** APPLY TEMPERATURE TENDENCY DUE TO RADIATION
	1071	!----------------------------------------------------------------------
	1072	!
	1073	btimx=timef()
	1074	!
	1075	! Pass in XTIME (elapsed time from start of parent) to compute
	1076	! the time passed into the zenith angle code consistently between
	1077	! RDTEMP and RADIATION.
	1078
	1079	CALL RDTEMP(NTSD,GRID%DT,GRID%JULDAY,GRID%JULYR &
	1080	& ,GRID%XTIME,IHRST,GLAT,GLON &
	1081	& ,CZEN,CZMEAN,T,RSWTT,RLWTT,HBM2 &
	1082	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1083	& ,IMS,IME,JMS,JME,KMS,KME &
	1084	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1085	!
	1086	rdtemp_tim=rdtemp_tim+timef()-btimx
	1087	!
	1088	!----------------------------------------------------------------------
	1089	!*** TURBULENT PROCESSES
	1090	!----------------------------------------------------------------------
	1091	!
	1092	IF(MOD(NTSD,GRID%NPHS)==0)THEN
	1093	!
	1094	btimx=timef()
	1095	!
	1096	IF(OPERATIONAL_PHYSICS &
	1097	& .AND.MOD(NTSD_rad,GRID%NRADS)/=0 &
	1098	& .AND.MOD(NTSD_rad,GRID%NRADL)/=0)THEN
	1099	CALL UPDATE_MOIST(MOIST,Q,CWM,F_ICE,F_RAIN,N_MOIST &
	1100	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1101	& ,IMS,IME,JMS,JME,KMS,KME &
	1102	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1103	ENDIF
	1104	!
	1105	CALL TURBL(NTSD,GRID%DT,GRID%NPHS,RESTRT &
	1106	& ,N_MOIST,GRID%NUM_SOIL_LAYERS,SLDPTH,DZSOIL &
	1107	& ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2,PDTOP,PT &
	1108	& ,SM,HBM2,VBM2,DX_NMM,DFRLG &
	1109	& ,CZEN,CZMEAN,SIGT4,RLWIN,RSWIN,RADOT &
	1110	& ,PD,RES,PINT,T,Q,CWM,F_ICE,F_RAIN,SR &
	1111	& ,Q2,U,V,THS,NMM_TSK,SST,PREC,SNO &
	1112	& ,FIS,Z0,Z0BASE,USTAR,PBLH,LPBL,EL_MYJ &
	1113	& ,MOIST,RMOL,MOL &
	1114	& ,EXCH_H,AKHS,AKMS,AKHS_OUT,AKMS_OUT &
	1115	& ,THZ0,QZ0,UZ0,VZ0,QSH,MAVAIL &
	1116	& ,STC,SMC,CMC,SMSTAV,SMSTOT,SSROFF,BGROFF &
	1117	& ,IVGTYP,ISLTYP,VEGFRC,SHDMIN,SHDMAX,GRNFLX &
	1118	& ,SFCEXC,ACSNOW,ACSNOM,SNOPCX,SICE,TG,SOILTB &
	1119	& ,ALBASE,MXSNAL,ALBEDO,SH2O,SI,EPSR,EMBCK &
	1120	& ,U10,V10,TH10,Q10,TSHLTR,QSHLTR,PSHLTR &
	1121	& ,T2,QSG,QVG,QCG,SOILT1,TSNAV,SMFR3D,KEEPFR3DFLAG &
	1122	& ,TWBS,QWBS,SFCSHX,SFCLHX,SFCEVP &
	1123	& ,POTEVP,POTFLX,SUBSHX &
	1124	& ,APHTIM,ARDSW,ARDLW,ASRFC &
	1125	& ,RSWOUT,RSWTOA,RLWTOA &
	1126	& ,ASWIN,ASWOUT,ASWTOA,ALWIN,ALWOUT,ALWTOA &
	1127	& ,UZ0H,VZ0H,DUDT,DVDT &
	1128	& ,RTHBLTEN,RQVBLTEN &
	1129	& ,GRID%PCPFLG,DDATA &
	1130	& ,GRID,CONFIG_FLAGS &
	1131	& ,IHE,IHW,IVE,IVW &
	1132	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1133	& ,IMS,IME,JMS,JME,KMS,KME &
	1134	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1135	!
	1136	! * NOTE *
	1137	! RLWIN/RSWIN - downward longwave/shortwave at the surface
	1138	! * NOTE *
	1139	!
	1140	turbl_tim=turbl_tim+timef()-btimx
	1141	!
	1142	btimx=timef()
	1143	!-----------------
	1144	#ifdef DM_PARALLEL
	1145	# include "HALO_NMM_TURBL_A.inc"
	1146	#endif
	1147	!-----------------
	1148	#ifdef DM_PARALLEL
	1149	# include "HALO_NMM_TURBL_B.inc"
	1150	#endif
	1151	!-----------------
	1152	exch_tim=exch_tim+timef()-btimx
	1153	! this_tim=timef()-btimx
	1154	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	1155	! & ,mpi_comm_comp,irtn)
	1156	! exch_tim_max=exch_tim_max+et_max
	1157	!
	1158	!*** INTERPOLATE WINDS FROM H POINTS BACK TO V POINTS.
	1159	!
	1160	btimx=timef()
	1161	CALL UV_H_TO_V(NTSD,GRID%DT,GRID%NPHS,UZ0H,VZ0H,UZ0,VZ0 &
	1162	& ,DUDT,DVDT,U,V,HBM2,IVE,IVW &
	1163	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1164	& ,IMS,IME,JMS,JME,KMS,KME &
	1165	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1166	uv_htov_tim=uv_htov_tim+timef()-btimx
	1167	!
	1168	!----------------------------------------------------------------------
	1169	!*** STORE ORIGINAL TEMPERATURE ARRAY
	1170	!----------------------------------------------------------------------
	1171	!
	1172	btimx=timef()
	1173	!-----------------
	1174	#ifdef DM_PARALLEL
	1175	# include "HALO_NMM_J.inc"
	1176	#endif
	1177	!
	1178	#ifdef DM_PARALLEL
	1179	IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW)THEN
	1180	# include "HALO_NMM_J_3.inc"
	1181	ENDIF
	1182	#endif
	1183	!
	1184	#ifdef WRF_CHEM
	1185	#ifdef DM_PARALLEL
	1186	# include "HALO_NMM_J_2.inc"
	1187	#endif
	1188	#endif
	1189	!-----------------
	1190	exch_tim=exch_tim+timef()-btimx
	1191	! this_tim=timef()-btimx
	1192	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	1193	! & ,mpi_comm_comp,irtn)
	1194	! exch_tim_max=exch_tim_max+et_max
	1195	!
	1196	ICLTEND=-1
	1197	btimx=timef()
	1198	!
	1199	CALL CLTEND(ICLTEND,GRID%NPHS,T,T_OLD,T_ADJ &
	1200	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1201	& ,IMS,IME,JMS,JME,KMS,KME &
	1202	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1203	!
	1204	cltend_tim=cltend_tim+timef()-btimx
	1205	ENDIF
	1206	!
	1207	!----------------------------------------------------------------------
	1208	!*** CONVECTIVE PRECIPITATION
	1209	!----------------------------------------------------------------------
	1210	!
	1211	IF(MOD(NTSD,GRID%NCNVC)==0.AND. &
	1212	& CONFIG_FLAGS%CU_PHYSICS==KFETASCHEME)THEN
	1213	!
	1214	btimx=timef()
	1215	!-----------------
	1216	#ifdef DM_PARALLEL
	1217	# include "HALO_NMM_C.inc"
	1218	#endif
	1219	!-----------------
	1220	exch_tim=exch_tim+timef()-btimx
	1221	! this_tim=timef()-btimx
	1222	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	1223	! & ,mpi_comm_comp,irtn)
	1224	! exch_tim_max=exch_tim_max+et_max
	1225	ENDIF
	1226	!
	1227	convection: IF(CONFIG_FLAGS%CU_PHYSICS/=0)THEN
	1228	btimx=timef()
	1229	!
	1230	!*** GET TENDENCIES FOR GD SCHEME.
	1231	!
	1232	IF(CONFIG_FLAGS%CU_PHYSICS==GDSCHEME)THEN
	1233	DT_INV=1./GRID%DT
	1234	DO J=JMS,JME
	1235	DO K=KMS,KME
	1236	DO I=IMS,IME
	1237	TTEN(I,K,J)=(T(I,J,K)-TTEN(I,K,J))*DT_INV
	1238	QTEN(I,K,J)=(Q(I,J,K)-QTEN(I,K,J))*DT_INV
	1239	ENDDO
	1240	ENDDO
	1241	ENDDO
	1242	ENDIF
	1243	!
	1244	!*** UPDATE THE MOIST ARRAY IF NEEDED.
	1245	!
	1246	IF(OPERATIONAL_PHYSICS &
	1247	& .AND.MOD(NTSD_rad,GRID%NRADS)/=0 &
	1248	& .AND.MOD(NTSD_rad,GRID%NRADL)/=0 &
	1249	& .AND.MOD(NTSD,GRID%NPHS)/=0)THEN
	1250	CALL UPDATE_MOIST(MOIST,Q,CWM,F_ICE,F_RAIN,N_MOIST &
	1251	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1252	& ,IMS,IME,JMS,JME,KMS,KME &
	1253	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1254	ENDIF
	1255	!
	1256	!----------------------------------------------------------------------
	1257	CALL CUCNVC(NTSD,GRID%DT,GRID%NCNVC,GRID%NRADS,GRID%NRADL &
	1258	& ,GPS,RESTRT,HYDRO,CLDEFI,N_MOIST,GRID%ENSDIM &
	1259	& ,MOIST &
	1260	& ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2 &
	1261	& ,F_ICE,F_RAIN &
	1262	!*** Changes for other cu schemes, most for GD scheme
	1263	& ,APR_GR,APR_W,APR_MC,TTEN,QTEN &
	1264	& ,APR_ST,APR_AS,APR_CAPMA &
	1265	& ,APR_CAPME,APR_CAPMI &
	1266	& ,MASS_FLUX,XF_ENS &
	1267	& ,PR_ENS,GSW &
	1268	#ifdef WRF_CHEM
	1269	& ,GD_CLOUD,GD_CLOUD2,RAINCV &
	1270	#endif
	1271	!
	1272	& ,PDTOP,PT,PD,RES,PINT,T,Q,CWM,TCUCN &
	1273	& ,OMGALF,U,V,W,Z,FIS,W0AVG &
	1274	& ,PREC,ACPREC,CUPREC,CUPPT,CPRATE &
	1275	& ,SM,HBM2,LPBL,CNVBOT,CNVTOP &
	1276	& ,HTOP,HBOT,HTOPD,HBOTD,HTOPS,HBOTS &
	1277	& ,RTHBLTEN,RQVBLTEN,RTHRATEN &
	1278	& ,AVCNVC,ACUTIM,IHE,IHW &
	1279	& ,GRID,CONFIG_FLAGS &
	1280	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1281	& ,IMS,IME,JMS,JME,KMS,KME &
	1282	& ,IPS,IPE,JPS,JPE,KPS,KPE &
	1283	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1284	!----------------------------------------------------------------------
	1285	!
	1286	cucnvc_tim=cucnvc_tim+timef()-btimx
	1287	!
	1288	ENDIF convection
	1289	!
	1290	!----------------------------------------------------------------------
	1291	!*** GRIDSCALE MICROPHYSICS (CONDENSATION & PRECIPITATION)
	1292	!----------------------------------------------------------------------
	1293	!
	1294	IF(MOD(NTSD,GRID%NPHS)==0)THEN
	1295	btimx=timef()
	1296	!
	1297	CALL GSMDRIVE(NTSD,GRID%DT,GRID%NPHS,N_MOIST &
	1298	& ,DX_NMM(ITS,JC),GRID%DY,SM,HBM2,FIS &
	1299	& ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2 &
	1300	& ,PDTOP,PT,PD,RES,PINT,T,Q,CWM,TRAIN &
	1301	& ,MOIST,SCALAR,NUM_SCALAR &
	1302	& ,F_ICE,F_RAIN,F_RIMEF,SR &
	1303	& ,PREC,ACPREC,AVRAIN &
	1304	& ,MP_RESTART_STATE &
	1305	& ,TBPVS_STATE &
	1306	& ,TBPVS0_STATE &
	1307	& ,GRID,CONFIG_FLAGS &
	1308	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1309	& ,IMS,IME,JMS,JME,KMS,KME &
	1310	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1311	!
	1312	gsmdrive_tim=gsmdrive_tim+timef()-btimx
	1313	!
	1314	!-----------------------------------------------------------------------
	1315	!---------PRECIPITATION ASSIMILATION------------------------------------
	1316	!-----------------------------------------------------------------------
	1317	!
	1318	IF (GRID%PCPFLG) THEN
	1319	btimx=timef()
	1320	!
	1321	CALL CHKSNOW(NTSD,GRID%DT,GRID%NPHS,SR,PPTDAT &
	1322	& ,IDS,IDE,JDS,JDE,KDS,KDE &
	1323	& ,IMS,IME,JMS,JME,KMS,KME &
	1324	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1325	CALL ADJPPT(NTSD,GRID%DT,GRID%NPHS,PREC,LSPA,PPTDAT,DDATA &
	1326	& ,IDS,IDE,JDS,JDE,KDS,KDE &
	1327	& ,IMS,IME,JMS,JME,KMS,KME &
	1328	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1329	!
	1330	adjppt_tim=adjppt_tim+timef()-btimx
	1331	ENDIF
	1332	!
	1333	!----------------------------------------------------------------------
	1334	!*** CALCULATE TEMP TENDENCIES AND RESTORE ORIGINAL TEMPS
	1335	!----------------------------------------------------------------------
	1336	!
	1337	ICLTEND=0
	1338	btimx=timef()
	1339	!
	1340	CALL CLTEND(ICLTEND,GRID%NPHS,T,T_OLD,T_ADJ &
	1341	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1342	& ,IMS,IME,JMS,JME,KMS,KME &
	1343	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1344	!
	1345	cltend_tim=cltend_tim+timef()-btimx
	1346	ENDIF
	1347	!
	1348	!----------------------------------------------------------------------
	1349	!*** UPDATE TEMP TENDENCIES FROM CLOUD PROCESSES EVERY TIME STEP
	1350	!----------------------------------------------------------------------
	1351	!
	1352	ICLTEND=1
	1353	btimx=timef()
	1354	!
	1355	CALL CLTEND(ICLTEND,GRID%NPHS,T,T_OLD,T_ADJ &
	1356	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1357	& ,IMS,IME,JMS,JME,KMS,KME &
	1358	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1359	!
	1360	cltend_tim=cltend_tim+timef()-btimx
	1361	!
	1362	!----------------------------------------------------------------------
	1363	!*** LATERAL DIFFUSION
	1364	!----------------------------------------------------------------------
	1365	!
	1366	btimx=timef()
	1367	!-----------------
	1368	#ifdef DM_PARALLEL
	1369	# include "HALO_NMM_K.inc"
	1370	#endif
	1371	!-----------------
	1372	exch_tim=exch_tim+timef()-btimx
	1373	! this_tim=timef()-btimx
	1374	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	1375	! & ,mpi_comm_comp,irtn)
	1376	! exch_tim_max=exch_tim_max+et_max
	1377	!
	1378	btimx=timef()
	1379	!
	1380	CALL HDIFF(NTSD,GRID%DT,FIS,DY_NMM,HDAC,HDACV &
	1381	& ,HBM2,DETA1,GRID%SIGMA &
	1382	& ,T,Q,U,V,Q2,Z,W,SM,SICE &
	1383	& ,IHE,IHW,IVE,IVW &
	1384	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1385	& ,IMS,IME,JMS,JME,KMS,KME &
	1386	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1387	!
	1388	IF(.NOT.OPERATIONAL_PHYSICS)THEN
	1389	DO K=KTS,KTE
	1390	DO J=MYJS,MYJE
	1391	DO I=MYIS,MYIE
	1392	!!! MOIST(I,J,K,P_QV)=MAX(0.,Q(I,J,K)/(1.-Q(I,J,K)))
	1393	MOIST(I,J,K,P_QV)=Q(I,J,K)/(1.-Q(I,J,K)) !<-- Update mixing ratio
	1394	ENDDO
	1395	ENDDO
	1396	ENDDO
	1397	ENDIF
	1398	!
	1399	hdiff_tim=hdiff_tim+timef()-btimx
	1400	!
	1401	!----------------------------------------------------------------------
	1402	!*** UPDATING BOUNDARY VALUES AT HEIGHT POINTS
	1403	!----------------------------------------------------------------------
	1404	!
	1405	btimx=timef()
	1406	!-----------------
	1407	#ifdef DM_PARALLEL
	1408	# include "HALO_NMM_L.inc"
	1409	#endif
	1410	!
	1411	#ifdef DM_PARALLEL
	1412	# include "HALO_NMM_L_3.inc"
	1413	#endif
	1414	!
	1415	#ifdef WRF_CHEM
	1416	#ifdef DM_PARALLEL
	1417	# include "HALO_NMM_L_2.inc"
	1418	#endif
	1419	#endif
	1420	!-----------------
	1421	exch_tim=exch_tim+timef()-btimx
	1422	! this_tim=timef()-btimx
	1423	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	1424	! & ,mpi_comm_comp,irtn)
	1425	! exch_tim_max=exch_tim_max+et_max
	1426	!
	1427	btimx=timef()
	1428	!
	1429	CALL BOCOH(GRID%ID,NTSD,GRID%DT,NEST,NUNIT_NBC,NBOCO,LAST_TIME,TSPH &
	1430	& ,LB,ETA1,ETA2,PDTOP,PT,RES &
	1431	& ,PD_BXS,PD_BXE,PD_BYS,PD_BYE,T_BXS,T_BXE,T_BYS,T_BYE &
	1432	& ,Q_BXS,Q_BXE,Q_BYS,Q_BYE,U_BXS,U_BXE,U_BYS,U_BYE,V_BXS &
	1433	& ,V_BXE,V_BYS,V_BYE,Q2_BXS,Q2_BXE,Q2_BYS,Q2_BYE,CWM_BXS &
	1434	& ,CWM_BXE,CWM_BYS,CWM_BYE,PD_BTXS,PD_BTXE,PD_BTYS &
	1435	& ,PD_BTYE,T_BTXS,T_BTXE,T_BTYS,T_BTYE,Q_BTXS,Q_BTXE &
	1436	& ,Q_BTYS,Q_BTYE,U_BTXS,U_BTXE,U_BTYS,U_BTYE,V_BTXS &
	1437	& ,V_BTXE,V_BTYS,V_BTYE,Q2_BTXS,Q2_BTXE,Q2_BTYS,Q2_BTYE &
	1438	& ,CWM_BTXS,CWM_BTXE,CWM_BTYS,CWM_BTYE,PD,T,Q,Q2,CWM,PINT &
	1439	& ,MOIST,N_MOIST,SCALAR,NUM_SCALAR &
	1440	#ifdef WRF_CHEM
	1441	& ,CHEM,NUMGAS,CONFIG_FLAGS &
	1442	#endif
	1443	& ,GRID%SPEC_BDY_WIDTH,Z &
	1444	& ,IHE,IHW,IVE,IVW &
	1445	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1446	& ,IMS,IME,JMS,JME,KMS,KME &
	1447	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1448
	1449
	1450	!
	1451	bocoh_tim=bocoh_tim+timef()-btimx
	1452	! if(mod(ntsd,n_print_time)==0)then
	1453	! call twr(t,0,'t',ntsd,mype,npes,mpi_comm_comp &
	1454	! & ,ids,ide,jds,jde,kds,kde &
	1455	! & ,ims,ime,jms,jme,kms,kme &
	1456	! & ,its,ite,jts,jte,kts,kte)
	1457	! endif
	1458	!
	1459	!----------------------------------------------------------------------
	1460	!*** IS IT TIME FOR A CHECK POINT ON THE MODEL HISTORY FILE?
	1461	!----------------------------------------------------------------------
	1462	!
	1463	2003 CONTINUE
	1464	!
	1465	!----------------------------------------------------------------------
	1466	!*** PRESSURE GRD, CORIOLIS, DIVERGENCE, AND HORIZ PART OF OMEGA-ALPHA
	1467	!----------------------------------------------------------------------
	1468	!
	1469	btimx=timef()
	1470	!-----------------
	1471	#ifdef DM_PARALLEL
	1472	# include "HALO_NMM_A.inc"
	1473	#endif
	1474	!
	1475	#ifdef DM_PARALLEL
	1476	IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW)THEN
	1477	# include "HALO_NMM_A_3.inc"
	1478	ENDIF
	1479	#endif
	1480	!
	1481	#ifdef WRF_CHEM
	1482	#ifdef DM_PARALLEL
	1483	# include "HALO_NMM_A_2.inc"
	1484	#endif
	1485	#endif
	1486	!-----------------
	1487	exch_tim=exch_tim+timef()-btimx
	1488	! this_tim=timef()-btimx
	1489	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	1490	! & ,mpi_comm_comp,irtn)
	1491	! exch_tim_max=exch_tim_max+et_max
	1492	!
	1493	btimx=timef()
	1494	!
	1495	CALL PFDHT(NTSD,LAST_TIME,PT,DETA1,DETA2,PDTOP,RES,FIS &
	1496	& ,HYDRO,GRID%SIGMA,FIRST,DX_NMM,DY_NMM &
	1497	& ,HBM2,VBM2,VBM3 &
	1498	& ,FDIV,FCP,WPDAR,DFL,CPGFU,CPGFV &
	1499	& ,PD,PDSL,T,Q,U,V,CWM,OMGALF,PINT,DWDT &
	1500	& ,RTOP,DIV,FEW,FNS,FNE,FSE &
	1501	& ,IHE,IHW,IVE,IVW &
	1502	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1503	& ,IMS,IME,JMS,JME,KMS,KME &
	1504	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1505
	1506	!
	1507	pfdht_tim=pfdht_tim+timef()-btimx
	1508	!
	1509	!----------------------------------------------------------------------
	1510	!*** DIVERGENCE DAMPING
	1511	!----------------------------------------------------------------------
	1512	!
	1513	btimx=timef()
	1514	!-----------------
	1515	#ifdef DM_PARALLEL
	1516	# include "HALO_NMM_B.inc"
	1517	#endif
	1518	!-----------------
	1519	exch_tim=exch_tim+timef()-btimx
	1520	! this_tim=timef()-btimx
	1521	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	1522	! & ,mpi_comm_comp,irtn)
	1523	! exch_tim_max=exch_tim_max+et_max
	1524	!
	1525	btimx=timef()
	1526	!
	1527	CALL DDAMP(NTSD,GRID%DT,DETA1,DETA2,PDSL,PDTOP,DIV,HBM2 &
	1528	& ,T,U,V,DDMPU,DDMPV &
	1529	& ,IHE,IHW,IVE,IVW &
	1530	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1531	& ,IMS,IME,JMS,JME,KMS,KME &
	1532	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1533	!
	1534	ddamp_tim=ddamp_tim+timef()-btimx
	1535	!
	1536	!----------------------------------------------------------------------
	1537	!----------------------------------------------------------------------
	1538	!
	1539	IF(FIRST.AND.NTSD==0)THEN
	1540	FIRST=.FALSE.
	1541	btimx=timef()
	1542	!-----------------
	1543	#ifdef DM_PARALLEL
	1544	# include "HALO_NMM_A.inc"
	1545	#endif
	1546	#ifdef WRF_CHEM
	1547	#ifdef DM_PARALLEL
	1548	# include "HALO_NMM_A_2.inc"
	1549	#endif
	1550	#endif
	1551	!-----------------
	1552	exch_tim=exch_tim+timef()-btimx
	1553	! this_tim=timef()-btimx
	1554	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	1555	! & ,mpi_comm_comp,irtn)
	1556	! exch_tim_max=exch_tim_max+et_max
	1557	!
	1558	GO TO 2000
	1559	ENDIF
	1560	!
	1561	!----------------------------------------------------------------------
	1562	!*** UPDATING BOUNDARY VALUES AT VELOCITY POINTS
	1563	!----------------------------------------------------------------------
	1564	!
	1565	btimx=timef()
	1566	!-----------------
	1567	#ifdef DM_PARALLEL
	1568	# include "HALO_NMM_C.inc"
	1569	#endif
	1570	!-----------------
	1571	exch_tim=exch_tim+timef()-btimx
	1572	! this_tim=timef()-btimx
	1573	! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max &
	1574	! & ,mpi_comm_comp,irtn)
	1575	! exch_tim_max=exch_tim_max+et_max
	1576	!
	1577	btimx=timef()
	1578	!
	1579	CALL BOCOV(GRID%ID,NTSD,GRID%DT,LB,U_BXS,U_BXE,U_BYS,U_BYE,V_BXS &
	1580	& ,V_BXE,V_BYS,V_BYE,U_BTXS,U_BTXE,U_BTYS,U_BTYE,V_BTXS &
	1581	& ,V_BTXE,V_BTYS,V_BTYE,U,V &
	1582	& ,GRID%SPEC_BDY_WIDTH &
	1583	& ,IHE,IHW,IVE,IVW &
	1584	& ,IDS,IDF,JDS,JDF,KDS,KDE &
	1585	& ,IMS,IME,JMS,JME,KMS,KME &
	1586	& ,ITS,ITE,JTS,JTE,KTS,KTE )
	1587
	1588	!
	1589	bocov_tim=bocov_tim+timef()-btimx
	1590	!
	1591	!----------------------------------------------------------------------
	1592	!*** COPY THE NMM VARIABLE Q2 TO THE WRF VARIABLE TKE_MYJ
	1593	!----------------------------------------------------------------------
	1594	!
	1595	DO K=KTS,KTE
	1596	DO J=JTS,JTE
	1597	DO I=ITS,ITE
	1598	TKE_MYJ(I,J,K)=0.5*Q2(I,J,K) !TKE is q squared over 2
	1599	ENDDO
	1600	ENDDO
	1601	ENDDO
	1602	!
	1603	!----------------------------------------------------------------------
	1604	!
	1605	IF(LAST_TIME.AND.ALLOCATED(PPTDAT))THEN
	1606	DEALLOCATE(PPTDAT,STAT=ISTAT)
	1607	ENDIF
	1608	!
	1609	!----------------------------------------------------------------------
	1610	!
	1611	solve_tim=solve_tim+timef()-btim
	1612	!
	1613	!----------------------------------------------------------------------
	1614	!*** PRINT TIMING VARIABLES WHEN DESIRED.
	1615	!----------------------------------------------------------------------
	1616	!
	1617	sum_tim=pdte_tim+adve_tim+vtoa_tim+vadz_tim+hadz_tim+eps_tim &
	1618	& +vad2_tim+had2_tim+radiation_tim+rdtemp_tim+turbl_tim &
	1619	& +cltend_tim+cucnvc_tim+gsmdrive_tim+hdiff_tim &
	1620	& +bocoh_tim+pfdht_tim+ddamp_tim+bocov_tim+uv_htov_tim &
	1621	& +exch_tim+adjppt_tim
	1622	!
	1623	if(mod(ntsd,n_print_time)==0)then
	1624	write(0,)' ntsd=',ntsd,' solve_tim=',solve_tim1.e-3 &
	1625	& ,' sum_tim=',sum_tim*1.e-3
	1626	write(0,)' pdte_tim=',pdte_tim1.e-3,' pct=',pdte_tim/sum_tim*100.
	1627	write(0,)' adve_tim=',adve_tim1.e-3,' pct=',adve_tim/sum_tim*100.
	1628	write(0,)' vtoa_tim=',vtoa_tim1.e-3,' pct=',vtoa_tim/sum_tim*100.
	1629	write(0,)' vadz_tim=',vadz_tim1.e-3,' pct=',vadz_tim/sum_tim*100.
	1630	write(0,)' hadz_tim=',hadz_tim1.e-3,' pct=',hadz_tim/sum_tim*100.
	1631	write(0,)' eps_tim=',eps_tim1.e-3,' pct=',eps_tim/sum_tim*100.
	1632	write(0,)' vad2_tim=',vad2_tim1.e-3,' pct=',vad2_tim/sum_tim*100.
	1633	write(0,)' had2_tim=',had2_tim1.e-3,' pct=',had2_tim/sum_tim*100.
	1634	write(0,)' radiation_tim=',radiation_tim1.e-3,' pct=',radiation_tim/sum_tim*100.
	1635	write(0,)' rdtemp_tim=',rdtemp_tim1.e-3,' pct=',rdtemp_tim/sum_tim*100.
	1636	write(0,)' turbl_tim=',turbl_tim1.e-3,' pct=',turbl_tim/sum_tim*100.
	1637	write(0,)' cltend_tim=',cltend_tim1.e-3,' pct=',cltend_tim/sum_tim*100.
	1638	write(0,)' cucnvc_tim=',cucnvc_tim1.e-3,' pct=',cucnvc_tim/sum_tim*100.
	1639	write(0,)' gsmdrive_tim=',gsmdrive_tim1.e-3,' pct=',gsmdrive_tim/sum_tim*100.
	1640	write(0,)' adjppt_tim=',adjppt_tim1.e-3,' pct=',adjppt_tim/sum_tim*100.
	1641	write(0,)' hdiff_tim=',hdiff_tim1.e-3,' pct=',hdiff_tim/sum_tim*100.
	1642	write(0,)' bocoh_tim=',bocoh_tim1.e-3,' pct=',bocoh_tim/sum_tim*100.
	1643	write(0,)' pfdht_tim=',pfdht_tim1.e-3,' pct=',pfdht_tim/sum_tim*100.
	1644	write(0,)' ddamp_tim=',ddamp_tim1.e-3,' pct=',ddamp_tim/sum_tim*100.
	1645	write(0,)' bocov_tim=',bocov_tim1.e-3,' pct=',bocov_tim/sum_tim*100.
	1646	write(0,)' uv_h_to_v_tim=',uv_htov_tim1.e-3,' pct=',uv_htov_tim/sum_tim*100.
	1647	write(0,)' exch_tim=',exch_tim1.e-3,' pct=',exch_tim/sum_tim*100.
	1648	! call time_stats(exch_tim,'exchange',ntsd,mype,npes,mpi_comm_comp)
	1649	! write(0,)' exch_tim_max=',exch_tim_max1.e-3
	1650	!
	1651	call field_stats(t,mype,mpi_comm_comp &
	1652	& ,ids,ide,jds,jde,kds,kde &
	1653	& ,ims,ime,jms,jme,kms,kme &
	1654	& ,its,ite,jts,jte,kts,kte)
	1655	endif
	1656	!
	1657	! if(last_time)then
	1658	DEALLOCATE(TTEN,STAT=ISTAT)
	1659	DEALLOCATE(QTEN,STAT=ISTAT)
	1660	DEALLOCATE(RTHRATEN,STAT=ISTAT)
	1661	DEALLOCATE(RTHBLTEN,STAT=ISTAT)
	1662	DEALLOCATE(RQVBLTEN,STAT=ISTAT)
	1663	#ifdef WRF_CHEM
	1664	DEALLOCATE(CHEM_TRANS,STAT=ISTAT)
	1665	#endif
	1666	!
	1667	#define COPY_OUT
	1668	#include <scalar_derefs.inc>
	1669	Return
	1670	!----------------------------------------------------------------------
	1671	!**********************************************************************
	1672	!**********************************************************************
	1673	!*********** EXIT FROM THE TIME LOOP ************************
	1674	!**********************************************************************
	1675	!**********************************************************************
	1676	!----------------------------------------------------------------------
	1677	END SUBROUTINE SOLVE_NMM
	1678	!----------------------------------------------------------------------
	1679	!**********************************************************************
	1680	!----------------------------------------------------------------------
	1681	SUBROUTINE TWR(ARRAY,KK,FIELD,NTSD,MYPE,NPES,MPI_COMM_COMP &
	1682	& ,IDS,IDE,JDS,JDE,KDS,KDE &
	1683	& ,IMS,IME,JMS,JME,KMS,KME &
	1684	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1685	!----------------------------------------------------------------------
	1686	!**********************************************************************
	1687	USE MODULE_EXT_INTERNAL
	1688	!
	1689	IMPLICIT NONE
	1690	#if defined(DM_PARALLEL) && !defined(STUBMPI)
	1691	INCLUDE "mpif.h"
	1692	#endif
	1693	!----------------------------------------------------------------------
	1694	!----------------------------------------------------------------------
	1695	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
	1696	& ,IMS,IME,JMS,JME,KMS,KME &
	1697	& ,ITS,ITE,JTS,JTE,KTS,KTE &
	1698	& ,KK,MPI_COMM_COMP,MYPE,NPES,NTSD
	1699	!
	1700	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME+KK),INTENT(IN) :: ARRAY
	1701	!
	1702	CHARACTER(*),INTENT(IN) :: FIELD
	1703	!
	1704	!*** LOCAL VARIABLES
	1705	!
	1706	#if defined(DM_PARALLEL) && !defined(STUBMPI)
	1707	INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT
	1708	INTEGER,DIMENSION(MPI_STATUS_SIZE,4) :: STATUS_ARRAY
	1709	#endif
	1710	INTEGER,DIMENSION(2) :: IM_REM,JM_REM,IT_REM,JT_REM
	1711	!
	1712	INTEGER :: I,IENDX,IER,IPE,IRECV,IRTN,ISEND,IUNIT &
	1713	& ,J,K,N,NLEN,NSIZE
	1714	INTEGER :: ITS_REM,ITE_REM,JTS_REM,JTE_REM
	1715	!
	1716	REAL,DIMENSION(IDS:IDE,JDS:JDE) :: TWRITE
	1717	REAL,ALLOCATABLE,DIMENSION(:) :: VALUES
	1718	CHARACTER(5) :: TIMESTEP
	1719	CHARACTER(6) :: FMT
	1720	CHARACTER(12) :: FILENAME
	1721	!----------------------------------------------------------------------
	1722	!**********************************************************************
	1723	!----------------------------------------------------------------------
	1724	!
	1725	IF(NTSD<=9)THEN
	1726	FMT='(I1.1)'
	1727	NLEN=1
	1728	ELSEIF(NTSD<=99)THEN
	1729	FMT='(I2.2)'
	1730	NLEN=2
	1731	ELSEIF(NTSD<=999)THEN
	1732	FMT='(I3.3)'
	1733	NLEN=3
	1734	ELSEIF(NTSD<=9999)THEN
	1735	FMT='(I4.4)'
	1736	NLEN=4
	1737	ELSEIF(NTSD<=99999)THEN
	1738	FMT='(I5.5)'
	1739	NLEN=5
	1740	ENDIF
	1741	WRITE(TIMESTEP,FMT)NTSD
	1742	FILENAME=FIELD//'_'//TIMESTEP(1:NLEN)
	1743	!
	1744	IF(MYPE==0)THEN
	1745	CALL INT_GET_FRESH_HANDLE(IUNIT)
	1746	CLOSE(IUNIT)
	1747	OPEN(UNIT=IUNIT,FILE=FILENAME,FORM='UNFORMATTED',IOSTAT=IER)
	1748	ENDIF
	1749	!
	1750	!----------------------------------------------------------------------
	1751	!!!! DO 500 K=KTS,KTE+KK !Unflipped
	1752	!!!! DO 500 K=KTE+KK,KTS,-1
	1753	DO 500 K=KDE-1,KDS,-1 !Write LM layers top down for checking
	1754	!----------------------------------------------------------------------
	1755	!
	1756	#if defined(DM_PARALLEL) && !defined(STUBMPI)
	1757	IF(MYPE==0)THEN
	1758	DO J=JTS,JTE
	1759	DO I=ITS,ITE
	1760	TWRITE(I,J)=ARRAY(I,J,K)
	1761	ENDDO
	1762	ENDDO
	1763	!
	1764	DO IPE=1,NPES-1
	1765	CALL MPI_RECV(IT_REM,2,MPI_INTEGER,IPE,IPE &
	1766	& ,MPI_COMM_COMP,JSTAT,IRECV)
	1767	CALL MPI_RECV(JT_REM,2,MPI_INTEGER,IPE,IPE &
	1768	& ,MPI_COMM_COMP,JSTAT,IRECV)
	1769	!
	1770	ITS_REM=IT_REM(1)
	1771	ITE_REM=IT_REM(2)
	1772	JTS_REM=JT_REM(1)
	1773	JTE_REM=JT_REM(2)
	1774	!
	1775	NSIZE=(ITE_REM-ITS_REM+1)*(JTE_REM-JTS_REM+1)
	1776	ALLOCATE(VALUES(1:NSIZE))
	1777	!
	1778	CALL MPI_RECV(VALUES,NSIZE,MPI_REAL,IPE,IPE &
	1779	& ,MPI_COMM_COMP,JSTAT,IRECV)
	1780	N=0
	1781	DO J=JTS_REM,JTE_REM
	1782	DO I=ITS_REM,ITE_REM
	1783	N=N+1
	1784	TWRITE(I,J)=VALUES(N)
	1785	ENDDO
	1786	ENDDO
	1787	!
	1788	DEALLOCATE(VALUES)
	1789	!
	1790	ENDDO
	1791	!
	1792	!----------------------------------------------------------------------
	1793	ELSE
	1794	NSIZE=(ITE-ITS+1)*(JTE-JTS+1)
	1795	ALLOCATE(VALUES(1:NSIZE))
	1796	!
	1797	N=0
	1798	DO J=JTS,JTE
	1799	DO I=ITS,ITE
	1800	N=N+1
	1801	VALUES(N)=ARRAY(I,J,K)
	1802	ENDDO
	1803	ENDDO
	1804	!
	1805	IT_REM(1)=ITS
	1806	IT_REM(2)=ITE
	1807	JT_REM(1)=JTS
	1808	JT_REM(2)=JTE
	1809	!
	1810	CALL MPI_SEND(IT_REM,2,MPI_INTEGER,0,MYPE &
	1811	& ,MPI_COMM_COMP,ISEND)
	1812	CALL MPI_SEND(JT_REM,2,MPI_INTEGER,0,MYPE &
	1813	& ,MPI_COMM_COMP,ISEND)
	1814	!
	1815	CALL MPI_SEND(VALUES,NSIZE,MPI_REAL,0,MYPE &
	1816	& ,MPI_COMM_COMP,ISEND)
	1817	!
	1818	DEALLOCATE(VALUES)
	1819	!
	1820	ENDIF
	1821	!----------------------------------------------------------------------
	1822	!
	1823	CALL MPI_BARRIER(MPI_COMM_COMP,IRTN)
	1824	!
	1825	IF(MYPE==0)THEN
	1826	!
	1827	DO J=JDS,JDE-1
	1828	IENDX=IDE-1
	1829	IF(MOD(J,2)==0)IENDX=IENDX-1
	1830	WRITE(IUNIT)(TWRITE(I,J),I=1,IENDX)
	1831	ENDDO
	1832	!
	1833	ENDIF
	1834	#else
	1835
	1836	DO J=JDS,JDE-1
	1837	IENDX=IDE-1
	1838	IF(MOD(J,2)==0)IENDX=IENDX-1
	1839	WRITE(IUNIT)(ARRAY(I,K,J),I=1,IENDX)
	1840	ENDDO
	1841
	1842	#endif
	1843
	1844	!
	1845	!----------------------------------------------------------------------
	1846	500 CONTINUE
	1847	!
	1848	IF(MYPE==0)CLOSE(IUNIT)
	1849	!----------------------------------------------------------------------
	1850	!
	1851	END SUBROUTINE TWR
	1852	!----------------------------------------------------------------------
	1853	!**********************************************************************
	1854	!----------------------------------------------------------------------
	1855	SUBROUTINE VWR(ARRAY,KK,FIELD,NTSD,MYPE,NPES,MPI_COMM_COMP &
	1856	& ,IDS,IDE,JDS,JDE,KDS,KDE &
	1857	& ,IMS,IME,JMS,JME,KMS,KME &
	1858	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	1859	!----------------------------------------------------------------------
	1860	!**********************************************************************
	1861	USE MODULE_EXT_INTERNAL
	1862	!
	1863	IMPLICIT NONE
	1864	#if defined(DM_PARALLEL) && !defined(STUBMPI)
	1865	INCLUDE "mpif.h"
	1866	#endif
	1867	!----------------------------------------------------------------------
	1868	!----------------------------------------------------------------------
	1869	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
	1870	& ,IMS,IME,JMS,JME,KMS,KME &
	1871	& ,ITS,ITE,JTS,JTE,KTS,KTE &
	1872	& ,KK,MPI_COMM_COMP,MYPE,NPES,NTSD
	1873	!
	1874	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME+KK),INTENT(IN) :: ARRAY
	1875	!
	1876	CHARACTER(*),INTENT(IN) :: FIELD
	1877	!
	1878	!*** LOCAL VARIABLES
	1879	!
	1880	#if defined(DM_PARALLEL) && !defined(STUBMPI)
	1881	INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT
	1882	INTEGER,DIMENSION(MPI_STATUS_SIZE,4) :: STATUS_ARRAY
	1883	#endif
	1884	INTEGER,DIMENSION(2) :: IM_REM,JM_REM,IT_REM,JT_REM
	1885	!
	1886	INTEGER :: I,IENDX,IER,IPE,IRECV,IRTN,ISEND,IUNIT &
	1887	& ,J,K,L,N,NLEN,NSIZE
	1888	INTEGER :: ITS_REM,ITE_REM,JTS_REM,JTE_REM
	1889	!
	1890	REAL,DIMENSION(IDS:IDE,JDS:JDE) :: TWRITE
	1891	REAL,ALLOCATABLE,DIMENSION(:) :: VALUES
	1892	CHARACTER(5) :: TIMESTEP
	1893	CHARACTER(6) :: FMT
	1894	CHARACTER(12) :: FILENAME
	1895	LOGICAL :: OPENED
	1896	!----------------------------------------------------------------------
	1897	!**********************************************************************
	1898	!----------------------------------------------------------------------
	1899	!
	1900	IF(NTSD<=9)THEN
	1901	FMT='(I1.1)'
	1902	NLEN=1
	1903	ELSEIF(NTSD<=99)THEN
	1904	FMT='(I2.2)'
	1905	NLEN=2
	1906	ELSEIF(NTSD<=999)THEN
	1907	FMT='(I3.3)'
	1908	NLEN=3
	1909	ELSEIF(NTSD<=9999)THEN
	1910	FMT='(I4.4)'
	1911	NLEN=4
	1912	ELSEIF(NTSD<=99999)THEN
	1913	FMT='(I5.5)'
	1914	NLEN=5
	1915	ENDIF
	1916	WRITE(TIMESTEP,FMT)NTSD
	1917	FILENAME=FIELD//'_'//TIMESTEP(1:NLEN)
	1918	!
	1919	IF(MYPE==0)THEN
	1920	CALL INT_GET_FRESH_HANDLE(IUNIT)
	1921	CLOSE(IUNIT)
	1922	OPEN(UNIT=IUNIT,FILE=FILENAME,FORM='UNFORMATTED',IOSTAT=IER)
	1923	ENDIF
	1924	! IF(MYPE==0)THEN
	1925	! OPEN_UNIT: DO L=51,99
	1926	! INQUIRE(L,OPENED=OPENED)
	1927	! IF(.NOT.OPENED)THEN
	1928	! IUNIT=L
	1929	! OPEN(UNIT=IUNIT,FILE=FILENAME,STATUS='NEW' &
	1930	! ,FORM='UNFORMATTED',IOSTAT=IER)
	1931	! IF(IER/=0)THEN
	1932	! WRITE(0,*)' Opening file error=',IER
	1933	! WRITE(6,*)' Opening file error=',IER
	1934	! ENDIF
	1935	! EXIT OPEN_UNIT
	1936	! ENDIF
	1937	! ENDDO OPEN_UNIT
	1938	! ENDIF
	1939	!
	1940	!----------------------------------------------------------------------
	1941	!!!! DO 500 K=KTS,KTE+KK !Unflipped
	1942	!!!! DO 500 K=KTE+KK,KTS,-1
	1943	DO 500 K=KDE-1,KDS,-1 !Write LM layers top down for checking
	1944	!----------------------------------------------------------------------
	1945	!
	1946	#if defined(DM_PARALLEL) && !defined(STUBMPI)
	1947	IF(MYPE==0)THEN
	1948	DO J=JTS,JTE
	1949	DO I=ITS,ITE
	1950	TWRITE(I,J)=ARRAY(I,J,K)
	1951	ENDDO
	1952	ENDDO
	1953	!
	1954	DO IPE=1,NPES-1
	1955	CALL MPI_RECV(IT_REM,2,MPI_INTEGER,IPE,IPE &
	1956	& ,MPI_COMM_COMP,JSTAT,IRECV)
	1957	CALL MPI_RECV(JT_REM,2,MPI_INTEGER,IPE,IPE &
	1958	& ,MPI_COMM_COMP,JSTAT,IRECV)
	1959	!
	1960	ITS_REM=IT_REM(1)
	1961	ITE_REM=IT_REM(2)
	1962	JTS_REM=JT_REM(1)
	1963	JTE_REM=JT_REM(2)
	1964	!
	1965	NSIZE=(ITE_REM-ITS_REM+1)*(JTE_REM-JTS_REM+1)
	1966	ALLOCATE(VALUES(1:NSIZE))
	1967	!
	1968	CALL MPI_RECV(VALUES,NSIZE,MPI_REAL,IPE,IPE &
	1969	& ,MPI_COMM_COMP,JSTAT,IRECV)
	1970	N=0
	1971	DO J=JTS_REM,JTE_REM
	1972	DO I=ITS_REM,ITE_REM
	1973	N=N+1
	1974	TWRITE(I,J)=VALUES(N)
	1975	ENDDO
	1976	ENDDO
	1977	!
	1978	DEALLOCATE(VALUES)
	1979	!
	1980	ENDDO
	1981	!
	1982	!----------------------------------------------------------------------
	1983	ELSE
	1984	NSIZE=(ITE-ITS+1)*(JTE-JTS+1)
	1985	ALLOCATE(VALUES(1:NSIZE))
	1986	!
	1987	N=0
	1988	DO J=JTS,JTE
	1989	DO I=ITS,ITE
	1990	N=N+1
	1991	VALUES(N)=ARRAY(I,J,K)
	1992	ENDDO
	1993	ENDDO
	1994	!
	1995	IT_REM(1)=ITS
	1996	IT_REM(2)=ITE
	1997	JT_REM(1)=JTS
	1998	JT_REM(2)=JTE
	1999	!
	2000	CALL MPI_SEND(IT_REM,2,MPI_INTEGER,0,MYPE &
	2001	& ,MPI_COMM_COMP,ISEND)
	2002	CALL MPI_SEND(JT_REM,2,MPI_INTEGER,0,MYPE &
	2003	& ,MPI_COMM_COMP,ISEND)
	2004	!
	2005	CALL MPI_SEND(VALUES,NSIZE,MPI_REAL,0,MYPE &
	2006	& ,MPI_COMM_COMP,ISEND)
	2007	!
	2008	DEALLOCATE(VALUES)
	2009	!
	2010	ENDIF
	2011	!----------------------------------------------------------------------
	2012	!
	2013	CALL MPI_BARRIER(MPI_COMM_COMP,IRTN)
	2014	!
	2015	IF(MYPE==0)THEN
	2016	!
	2017	DO J=JDS,JDE-1
	2018	IENDX=IDE-1
	2019	IF(MOD(J,2)==1)IENDX=IENDX-1
	2020	WRITE(IUNIT)(TWRITE(I,J),I=1,IENDX)
	2021	ENDDO
	2022	!
	2023	ENDIF
	2024	#else
	2025
	2026	DO J=JDS,JDE-1
	2027	IENDX=IDE-1
	2028	IF(MOD(J,2)==0)IENDX=IENDX-1
	2029	WRITE(IUNIT)(ARRAY(I,K,J),I=1,IENDX)
	2030	ENDDO
	2031
	2032	#endif
	2033	!
	2034	!----------------------------------------------------------------------
	2035	500 CONTINUE
	2036	!
	2037	IF(MYPE==0)CLOSE(IUNIT)
	2038	!----------------------------------------------------------------------
	2039	!
	2040	END SUBROUTINE VWR
	2041	!----------------------------------------------------------------------
	2042	!**********************************************************************
	2043	!----------------------------------------------------------------------
	2044	SUBROUTINE EXIT(NAME,PINT,T,Q,U,V,Q2,W &
	2045	& ,NTSD,MYPE,MPI_COMM_COMP &
	2046	& ,IDS,IDE,JDS,JDE,KDS,KDE &
	2047	& ,IMS,IME,JMS,JME,KMS,KME &
	2048	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	2049	!----------------------------------------------------------------------
	2050	!**********************************************************************
	2051	USE MODULE_EXT_INTERNAL
	2052	!
	2053	!----------------------------------------------------------------------
	2054	IMPLICIT NONE
	2055	!----------------------------------------------------------------------
	2056	#if defined(DM_PARALLEL) && !defined(STUBMPI)
	2057	INCLUDE "mpif.h"
	2058	#endif
	2059	!----------------------------------------------------------------------
	2060	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
	2061	& ,IMS,IME,JMS,JME,KMS,KME &
	2062	& ,ITS,ITE,JTS,JTE,KTS,KTE &
	2063	& ,MYPE,MPI_COMM_COMP,NTSD
	2064	!
	2065	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT,T,Q &
	2066	,U,V,Q2,W
	2067	CHARACTER(*),INTENT(IN) :: NAME
	2068	!
	2069	INTEGER :: I,J,K,IEND,IERR,IRET
	2070	CHARACTER(256) :: ERRMESS
	2071	LOGICAL :: E_BDY,S_BDY
	2072	!----------------------------------------------------------------------
	2073	IRET=0
	2074	100 FORMAT(' EXIT ',A,' AT NTSD=',I5)
	2075	IEND=ITE
	2076	S_BDY=(JTS==JDS)
	2077	E_BDY=(ITE==IDE-1)
	2078	!
	2079	DO K=KTS,KTE
	2080	DO J=JTS,JTE
	2081	IEND=ITE
	2082	IF(E_BDY.AND.MOD(J,2)==0)IEND=ITE-1
	2083	!
	2084	DO I=ITS,IEND
	2085	IF(T(I,J,K)>330..OR.T(I,J,K)<180..OR.T(I,J,K)/=T(I,J,K))THEN
	2086	WRITE(0,100)NAME,NTSD
	2087	WRITE(0,200)I,J,K,T(I,J,K),MYPE,NTSD
	2088	200 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' T=',E12.5 &
	2089	&, ' MYPE=',I3,' NTSD=',I5)
	2090	IRET=666
	2091	return
	2092	! WRITE(ERRMESS,205)NAME,T(I,J,K),I,J,K,MYPE
	2093	205 FORMAT(' EXIT ',A,' TEMPERATURE=',E12.5 &
	2094	&, ' AT (',I3,',',I2,',',I3,')',' MYPE=',I3)
	2095	! CALL WRF_ERROR_FATAL(ERRMESS)
	2096	! CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR)
	2097	ELSEIF(Q(I,J,K)<-1.E-4.OR.Q(I,J,K)>30.E-3 &
	2098	& .OR.Q(I,J,K)/=Q(I,J,K))THEN
	2099	WRITE(0,100)NAME,NTSD
	2100	WRITE(0,300)I,J,K,Q(I,J,K),MYPE,NTSD
	2101	300 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' Q=',E12.5 &
	2102	&, ' MYPE=',I3,' NTSD=',I5)
	2103	IRET=666
	2104	return
	2105	! WRITE(ERRMESS,305)NAME,Q(I,J,K),I,J,K,MYPE
	2106	305 FORMAT(' EXIT ',A,' SPEC HUMIDITY=',E12.5 &
	2107	&, ' AT (',I3,',',I2,',',I3,')',' MYPE=',I3)
	2108	! CALL WRF_ERROR_FATAL(ERRMESS)
	2109	! CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR)
	2110	ELSEIF(PINT(I,J,K)<0..OR.PINT(I,J,K)/=PINT(I,J,K))THEN
	2111	WRITE(0,100)NAME,NTSD
	2112	WRITE(0,315)I,J,K,PINT(I,J,K),MYPE,NTSD
	2113	315 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' PINT=',E12.5 &
	2114	&, ' MYPE=',I3,' NTSD=',I5)
	2115	IRET=666
	2116	return
	2117	! CALL WRF_ERROR_FATAL(ERRMESS)
	2118	! CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR)
	2119	ELSEIF(W(I,J,K)/=W(I,J,K))THEN
	2120	WRITE(0,100)NAME,NTSD
	2121	WRITE(0,325)I,J,K,W(I,J,K),MYPE,NTSD
	2122	325 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' W=',E12.5 &
	2123	&, ' MYPE=',I3,' NTSD=',I5)
	2124	IRET=666
	2125	return
	2126	! CALL WRF_ERROR_FATAL(ERRMESS)
	2127	! CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR)
	2128	ENDIF
	2129	ENDDO
	2130	ENDDO
	2131	ENDDO
	2132	!
	2133	DO K=KTS,KTE
	2134	DO J=JTS,JTE
	2135	IEND=ITE
	2136	IF(E_BDY.AND.MOD(J,2)==1)IEND=ITE-1
	2137	DO I=ITS,IEND
	2138	IF(ABS(U(I,J,K))>125..OR.ABS(V(I,J,K))>125. &
	2139	& .OR.U(I,J,K)/=U(I,J,K).OR.V(I,J,K)/=V(I,J,K))THEN
	2140	WRITE(0,100)NAME,NTSD
	2141	WRITE(0,400)I,J,K,U(I,J,K),V(I,J,K),MYPE,NTSD
	2142	400 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' U=',E12.5 &
	2143	&, ' V=',E12.5,' MYPE=',I3,' NTSD=',I5)
	2144	IRET=666
	2145	return
	2146	! WRITE(ERRMESS,405)NAME,U(I,J,K),V(I,J,K),I,J,K,MYPE
	2147	405 FORMAT(' EXIT ',A,' U=',E12.5,' V=',E12.5 &
	2148	&, ' AT (',I3,',',I2,',',I3,')',' MYPE=',I3)
	2149	! CALL WRF_ERROR_FATAL(ERRMESS)
	2150	! CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR)
	2151	ENDIF
	2152	ENDDO
	2153	ENDDO
	2154	ENDDO
	2155	!----------------------------------------------------------------------
	2156	END SUBROUTINE EXIT
	2157	!----------------------------------------------------------------------
	2158	!**********************************************************************
	2159	!----------------------------------------------------------------------
	2160	SUBROUTINE TIME_STATS(TIME_LCL,NAME,NTSD,MYPE,NPES,MPI_COMM_COMP)
	2161	!----------------------------------------------------------------------
	2162	!**********************************************************************
	2163	USE MODULE_EXT_INTERNAL
	2164	!
	2165	!----------------------------------------------------------------------
	2166	IMPLICIT NONE
	2167	!----------------------------------------------------------------------
	2168	#if defined(DM_PARALLEL) && !defined(STUBMPI)
	2169	INCLUDE "mpif.h"
	2170	#endif
	2171	!----------------------------------------------------------------------
	2172	INTEGER,INTENT(IN) :: MPI_COMM_COMP,MYPE,NPES,NTSD
	2173	REAL,INTENT(IN) :: TIME_LCL
	2174	!
	2175	CHARACTER(*),INTENT(IN) :: NAME
	2176	!
	2177	!*** LOCAL VARIABLES
	2178	!
	2179	#if defined(DM_PARALLEL) && !defined(STUBMPI)
	2180	INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT
	2181	INTEGER,DIMENSION(MPI_STATUS_SIZE,4) :: STATUS_ARRAY
	2182	#endif
	2183	INTEGER,ALLOCATABLE,DIMENSION(:) :: ID_PE,IPE_SORT
	2184	!
	2185	INTEGER :: IPE,IPE_MAX,IPE_MEDIAN,IPE_MIN,IRECV,IRTN,ISEND &
	2186	& ,N,N_MEDIAN,NLEN
	2187	!
	2188	REAL,ALLOCATABLE,DIMENSION(:) :: TIME,SORT_TIME
	2189	REAL,DIMENSION(2) :: REMOTE
	2190	REAL :: TIME_MAX,TIME_MEAN,TIME_MEDIAN,TIME_MIN
	2191	!
	2192	CHARACTER(5) :: TIMESTEP
	2193	CHARACTER(6) :: FMT
	2194	CHARACTER(25) :: TITLE
	2195	!----------------------------------------------------------------------
	2196	!**********************************************************************
	2197	!----------------------------------------------------------------------
	2198	!
	2199	IF(NTSD<=9)THEN
	2200	FMT='(I1.1)'
	2201	NLEN=1
	2202	ELSEIF(NTSD<=99)THEN
	2203	FMT='(I2.2)'
	2204	NLEN=2
	2205	ELSEIF(NTSD<=999)THEN
	2206	FMT='(I3.3)'
	2207	NLEN=3
	2208	ELSEIF(NTSD<=9999)THEN
	2209	FMT='(I4.4)'
	2210	NLEN=4
	2211	ELSEIF(NTSD<=99999)THEN
	2212	FMT='(I5.5)'
	2213	NLEN=5
	2214	ENDIF
	2215	WRITE(TIMESTEP,FMT)NTSD
	2216	TITLE=NAME//'_'//TIMESTEP(1:NLEN)
	2217	!
	2218	!----------------------------------------------------------------------
	2219	!
	2220	#if defined(DM_PARALLEL) && !defined(STUBMPI)
	2221	IF(MYPE==0)THEN
	2222	ALLOCATE(TIME(1:NPES))
	2223	ALLOCATE(SORT_TIME(1:NPES))
	2224	ALLOCATE(ID_PE(1:NPES))
	2225	ALLOCATE(IPE_SORT(1:NPES))
	2226	!
	2227	TIME(1)=TIME_LCL
	2228	ID_PE(1)=MYPE
	2229	!
	2230	!*** COLLECT TIMES AND PE VALUES FROM OTHER PEs
	2231	!
	2232	DO IPE=1,NPES-1
	2233	CALL MPI_RECV(REMOTE,2,MPI_REAL,IPE,IPE &
	2234	& ,MPI_COMM_COMP,JSTAT,IRECV)
	2235	!
	2236	TIME(IPE+1)=REMOTE(1)
	2237	ID_PE(IPE+1)=NINT(REMOTE(2))
	2238	ENDDO
	2239	!
	2240	!*** NOW GET STATS.
	2241	!*** FIRST THE MAX, MIN, AND MEAN TIMES.
	2242	!
	2243	TIME_MEAN=0.
	2244	TIME_MAX=-1.
	2245	TIME_MIN=1.E10
	2246	IPE_MAX=-1
	2247	IPE_MIN=-1
	2248	!
	2249	DO N=1,NPES
	2250	TIME_MEAN=TIME_MEAN+TIME(N)
	2251	!
	2252	IF(TIME(N)>TIME_MAX)THEN
	2253	TIME_MAX=TIME(N)
	2254	IPE_MAX=ID_PE(N)
	2255	ENDIF
	2256	!
	2257	IF(TIME(N)<TIME_MIN)THEN
	2258	TIME_MIN=TIME(N)
	2259	IPE_MIN=ID_PE(N)
	2260	ENDIF
	2261	!
	2262	ENDDO
	2263	!
	2264	TIME_MAX=TIME_MAX*1.E-3
	2265	TIME_MIN=TIME_MIN*1.E-3
	2266	TIME_MEAN=TIME_MEAN*1.E-3/REAL(NPES)
	2267	!
	2268	!*** THEN THE MEDIAN TIME.
	2269	!
	2270	CALL SORT(TIME,NPES,SORT_TIME,IPE_SORT)
	2271	N_MEDIAN=(NPES+1)/2
	2272	TIME_MEDIAN=SORT_TIME(N_MEDIAN)*1.E-3
	2273	IPE_MEDIAN=IPE_SORT(N_MEDIAN)
	2274	!
	2275	!----------------------------------------------------------------------
	2276	ELSE
	2277	!
	2278	!*** SEND TIME AND PE VALUE TO PE0.
	2279	!
	2280	REMOTE(1)=TIME_LCL
	2281	REMOTE(2)=REAL(MYPE)
	2282	!
	2283	CALL MPI_SEND(REMOTE,2,MPI_REAL,0,MYPE,MPI_COMM_COMP,ISEND)
	2284	!
	2285	ENDIF
	2286	!----------------------------------------------------------------------
	2287	!
	2288	CALL MPI_BARRIER(MPI_COMM_COMP,IRTN)
	2289	!
	2290	!*** WRITE RESULTS
	2291	!
	2292	IF(MYPE==0)THEN
	2293	WRITE(0,100)TITLE
	2294	WRITE(0,105)TIME_MAX,IPE_MAX
	2295	WRITE(0,110)TIME_MIN,IPE_MIN
	2296	WRITE(0,115)TIME_MEDIAN,IPE_MEDIAN
	2297	WRITE(0,120)TIME_MEAN
	2298	100 FORMAT(' Time for ',A)
	2299	105 FORMAT(' Maximum=',G11.5,' for PE ',I2.2)
	2300	110 FORMAT(' Minimum=',G11.5,' for PE ',I2.2)
	2301	115 FORMAT(' Median =',G11.5,' for PE ',I2.2)
	2302	120 FORMAT(' Mean =',G11.5)
	2303	ENDIF
	2304	!----------------------------------------------------------------------
	2305	!
	2306	#endif
	2307	END SUBROUTINE TIME_STATS
	2308	!
	2309	!----------------------------------------------------------------------
	2310	!**********************************************************************
	2311	!----------------------------------------------------------------------
	2312	SUBROUTINE SORT(DATA,NPES,DATA_SORTED,IPE_SORTED)
	2313	!----------------------------------------------------------------------
	2314	!***
	2315	!*** SORT DATA FROM MULTIPLE PEs. SEND BACK THE SORTED DATA ITEMS
	2316	!*** ALONG WITH THE ASSOCIATED TASK IDs.
	2317	!***
	2318	!----------------------------------------------------------------------
	2319	IMPLICIT NONE
	2320	!----------------------------------------------------------------------
	2321	INTEGER,INTENT(IN) :: NPES
	2322	REAL,DIMENSION(NPES),INTENT(IN) :: DATA
	2323	!
	2324	INTEGER,DIMENSION(NPES),INTENT(OUT) :: IPE_SORTED
	2325	REAL,DIMENSION(NPES),INTENT(OUT) :: DATA_SORTED
	2326	!----------------------------------------------------------------------
	2327	TYPE :: DATA_LINK
	2328	REAL :: VALUE
	2329	INTEGER :: IPE
	2330	TYPE(DATA_LINK),POINTER :: NEXT_VALUE
	2331	END TYPE
	2332	!----------------------------------------------------------------------
	2333	!
	2334	!*** LOCAL VARIABLES
	2335	!
	2336	!----------------------------------------------------------------------
	2337	INTEGER :: ISTAT,N
	2338	!
	2339	TYPE(DATA_LINK),POINTER :: HEAD,TAIL ! Smallest, largest
	2340	TYPE(DATA_LINK),POINTER :: PTR_NEW ! Each new value
	2341	TYPE(DATA_LINK),POINTER :: PTR1,PTR2 ! Working pointers
	2342	!----------------------------------------------------------------------
	2343	!**********************************************************************
	2344	!----------------------------------------------------------------------
	2345	pe_loop: DO N=1,NPES
	2346	ALLOCATE(PTR_NEW,STAT=ISTAT) ! Location for next data items
	2347	PTR_NEW%VALUE=DATA(N)
	2348	PTR_NEW%IPE=N-1
	2349	!
	2350	!----------------------------------------------------------------------
	2351	!*** DETERMINE WHERE IN LIST TO INSERT VALUE.
	2352	!*** FIRST THE INITIAL DATA VALUE.
	2353	!----------------------------------------------------------------------
	2354	!
	2355	! main: IF(.NOT.ASSOCIATED(HEAD))THEN
	2356	main: IF(N==1)THEN
	2357	HEAD=>PTR_NEW
	2358	TAIL=>HEAD
	2359	NULLIFY(PTR_NEW%NEXT_VALUE)
	2360	!
	2361	!----------------------------------------------------------------------
	2362	!*** THE NEW VALUE IS LESS THAN THE SMALLEST VALUE ALREADY SORTED.
	2363	!----------------------------------------------------------------------
	2364	!
	2365	ELSE
	2366	check: IF(PTR_NEW%VALUE<HEAD%VALUE)THEN
	2367	PTR_NEW%NEXT_VALUE=>HEAD
	2368	HEAD=>PTR_NEW
	2369	!
	2370	!----------------------------------------------------------------------
	2371	!*** THE NEW VALUE IS GREATER THAN THE LARGEST VALUE ALREADY SORTED.
	2372	!----------------------------------------------------------------------
	2373	!
	2374	ELSEIF(PTR_NEW%VALUE>=TAIL%VALUE)THEN
	2375	TAIL%NEXT_VALUE=>PTR_NEW ! This is what connects the former
	2376	! final value in the list to
	2377	! the new value being appended.
	2378	TAIL=>PTR_NEW
	2379	NULLIFY(TAIL%NEXT_VALUE)
	2380	!
	2381	!----------------------------------------------------------------------
	2382	!*** THE NEW VALUE IS IN BETWEEN VALUES ALREADY SORTED.
	2383	!----------------------------------------------------------------------
	2384	!
	2385	ELSE
	2386	PTR1=>HEAD
	2387	PTR2=>PTR1%NEXT_VALUE
	2388	!
	2389	search: DO
	2390	IF((PTR_NEW%VALUE>=PTR1%VALUE).AND. &
	2391	& (PTR_NEW%VALUE<PTR2%VALUE))THEN
	2392	PTR_NEW%NEXT_VALUE=>PTR2
	2393	PTR1%NEXT_VALUE=>PTR_NEW
	2394	EXIT search
	2395	ENDIF
	2396	!
	2397	PTR1=>PTR2
	2398	PTR2=>PTR2%NEXT_VALUE
	2399	ENDDO search
	2400	!
	2401	ENDIF check
	2402	!
	2403	ENDIF main
	2404	!
	2405	ENDDO pe_loop
	2406	!
	2407	!----------------------------------------------------------------------
	2408	!*** COLLECT THE SORTED NUMBERS FROM THE LINKED LIST.
	2409	!----------------------------------------------------------------------
	2410	!
	2411	PTR1=>HEAD
	2412	!
	2413	DO N=1,NPES
	2414	! IF(.NOT.ASSOCIATED(PTR_NEW))EXIT
	2415	DATA_SORTED(N)=PTR1%VALUE
	2416	IPE_SORTED(N)=PTR1%IPE
	2417	PTR1=>PTR1%NEXT_VALUE
	2418	ENDDO
	2419	!
	2420	DEALLOCATE(PTR_NEW)
	2421	NULLIFY (HEAD,TAIL,PTR1,PTR2)
	2422	!----------------------------------------------------------------------
	2423	END SUBROUTINE SORT
	2424	!----------------------------------------------------------------------
	2425	!**********************************************************************
	2426	!----------------------------------------------------------------------
	2427	SUBROUTINE FIELD_STATS(FIELD,MYPE,MPI_COMM_COMP &
	2428	& ,IDS,IDE,JDS,JDE,KDS,KDE &
	2429	& ,IMS,IME,JMS,JME,KMS,KME &
	2430	& ,ITS,ITE,JTS,JTE,KTS,KTE)
	2431	!----------------------------------------------------------------------
	2432	!***
	2433	!*** GENERATE STANDARD LAYER STATISTICS FOR THE DESIRED FIELD.
	2434	!***
	2435	!----------------------------------------------------------------------
	2436	IMPLICIT NONE
	2437	!----------------------------------------------------------------------
	2438	#if defined(DM_PARALLEL) && !defined(STUBMPI)
	2439	INCLUDE "mpif.h"
	2440	#endif
	2441	!----------------------------------------------------------------------
	2442	!
	2443	INTEGER,INTENT(IN) :: MPI_COMM_COMP,MYPE
	2444	INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
	2445	& ,IMS,IME,JMS,JME,KMS,KME &
	2446	& ,ITS,ITE,JTS,JTE,KTS,KTE
	2447	!
	2448	REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: FIELD
	2449	!
	2450	!----------------------------------------------------------------------
	2451	!*** LOCAL
	2452	!----------------------------------------------------------------------
	2453	!
	2454	INTEGER,PARAMETER :: DOUBLE=SELECTED_REAL_KIND(15,300)
	2455	!
	2456	INTEGER :: I,IEND,IRTN,I_BY_J,J,K,KFLIP
	2457	!
	2458	REAL :: FIKJ,FMAXK,FMINK
	2459	REAL(KIND=DOUBLE) :: F_MEAN,POINTS,RMS,ST_DEV,SUMFK,SUMF2K
	2460	REAL,DIMENSION(KTS:KTE) :: FMAX,FMAX_0,FMIN,FMIN_0
	2461	REAL(KIND=DOUBLE),DIMENSION(KTS:KTE) :: SUMF,SUMF_0,SUMF2,SUMF2_0
	2462	!----------------------------------------------------------------------
	2463	!
	2464	I_BY_J=(IDE-IDS)*(JDE-JDS)-(JDE-JDS-1)/2 ! This assumes that
	2465	! IDE and JDE are each
	2466	! one greater than the
	2467	! true grid size.
	2468	#if defined(DM_PARALLEL) && !defined(STUBMPI)
	2469	!
	2470	layer_loop: DO K=KTS,KTE
	2471	!
	2472	FMAXK=-1.E10
	2473	FMINK=1.E10
	2474	SUMFK=0.
	2475	SUMF2K=0.
	2476	!
	2477	DO J=JTS,JTE
	2478	IEND=MIN(ITE,IDE-1)
	2479	IF(MOD(J,2)==0.AND.ITE==IDE-1)IEND=IEND-1
	2480	DO I=ITS,IEND
	2481	FIKJ=FIELD(I,J,K)
	2482	FMAXK=MAX(FMAXK,FIKJ)
	2483	FMINK=MIN(FMINK,FIKJ)
	2484	SUMFK=SUMFK+FIKJ
	2485	SUMF2K=SUMF2K+FIKJ*FIKJ
	2486	ENDDO
	2487	ENDDO
	2488	!
	2489	FMAX(K)=FMAXK
	2490	FMIN(K)=FMINK
	2491	SUMF(K)=SUMFK
	2492	SUMF2(K)=SUMF2K
	2493	!
	2494	ENDDO layer_loop
	2495	!
	2496	!----------------------------------------------------------------------
	2497	!*** GLOBAL STATS
	2498	!----------------------------------------------------------------------
	2499	!
	2500	CALL MPI_REDUCE(SUMF,SUMF_0,KTE,MPI_REAL8,MPI_SUM,0 &
	2501	& ,MPI_COMM_COMP,IRTN)
	2502	CALL MPI_REDUCE(SUMF2,SUMF2_0,KTE,MPI_REAL8,MPI_SUM,0 &
	2503	& ,MPI_COMM_COMP,IRTN)
	2504	CALL MPI_REDUCE(FMAX,FMAX_0,KTE,MPI_REAL,MPI_MAX,0 &
	2505	& ,MPI_COMM_COMP,IRTN)
	2506	CALL MPI_REDUCE(FMIN,FMIN_0,KTE,MPI_REAL,MPI_MIN,0 &
	2507	& ,MPI_COMM_COMP,IRTN)
	2508	!
	2509	IF(MYPE==0)THEN
	2510	POINTS=I_BY_J
	2511	DO K=KTE,KTS,-1
	2512	F_MEAN=SUMF_0(K)/POINTS
	2513	ST_DEV=SQRT((POINTSSUMF2_0(K)-SUMF_0(K)SUMF_0(K))/ &
	2514	& (POINTS*(POINTS-1)))
	2515	RMS=SQRT(SUMF2_0(K)/POINTS)
	2516	KFLIP=KTE-K+1
	2517	WRITE(0,101)KFLIP,FMAX_0(K),FMIN_0(K)
	2518	WRITE(0,102)F_MEAN,ST_DEV,RMS
	2519	101 FORMAT(' LAYER=',I2,' MAX=',E13.6,' MIN=',E13.6)
	2520	102 FORMAT(9X,' MEAN=',E13.6,' STDEV=',E13.6,' RMS=',E13.6)
	2521	ENDDO
	2522	ENDIF
	2523	#endif
	2524	!----------------------------------------------------------------------
	2525	END SUBROUTINE FIELD_STATS
	2526	!----------------------------------------------------------------------
	2527	FUNCTION TIMEF()
	2528	REAL*8 TIMEF
	2529	INTEGER :: IC,IR
	2530	CALL SYSTEM_CLOCK(COUNT=IC,COUNT_RATE=IR)
	2531	TIMEF=REAL(IC)/REAL(IR)*1000.0
	2532	END

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format