! Initialize moisture, mass, energy, and temperature integrals!   hw1(1) = 0.   engy1  = 0.   engy2a = 0.   engy2b = 0.   diffta = 0.   difftb = 0.   do m=1,pcnst      hw2a(m) = 0.      hw2b(m) = 0.      hw3a(m) = 0.      hw3b(m) = 0.      do n=1,4         hwxa(m,n) = 0.         hwxb(m,n) = 0.      end do   end do!! Sum water and energy integrals over latitudes!   do lat=1,plat      engy1   = engy1   + engy1lat (lat)      engy2a  = engy2a  + engy2alat(lat)      engy2b  = engy2b  + engy2blat(lat)      diffta  = diffta  + difftalat(lat)      difftb  = difftb  + difftblat(lat)      hw1(1)  = hw1(1)  + hw1lat(1,lat)      hw2a(1) = hw2a(1) + hw2al(1,lat)      hw2b(1) = hw2b(1) + hw2bl(1,lat)      hw3a(1) = hw3a(1) + hw3al(1,lat)      hw3b(1) = hw3b(1) + hw3bl(1,lat)   end do!! Compute atmospheric mass fixer coefficient!   qmassf     = hw1(1)   if (adiabatic .or. ideal_phys) then      fixmas = tmass0/tmassf   else      fixmas = (tmass0 + qmassf)/tmassf   end if!! Compute alpha for water ONLY!   hw2(1)    = hw2a(1) + fixmas*hw2b(1)   hw3(1)    = hw3a(1) + fixmas*hw3b(1)   if(hw3(1) .ne. 0.) then      alpha(1)  = ( hw1(1) - hw2(1) )/hw3(1)   else      alpha(1)  = 1.   endif!! Compute beta for energy!   engy2    = engy2a + fixmas*engy2b   difft    = diffta + fixmas*difftb   residual = (engy2 - engy1)/ztodt   if(difft .ne. 0.) then     beta = -residual*ztodt/(cpair*difft)   else     beta = 0.   endif!!   write(6,125) residual,beta!!125 format('      resid, beta      = ',25x,2f25.15)!! Compute alpha for non-water constituents!   do m = 2,pcnst      hw1(m) = 0.      do lat=1,plat         hw1(m) = hw1(m) + hw1lat(m,lat)      end do      do n = 1,4         do lat=1,plat            hwxa(m,n) = hwxa(m,n) + hwxal(m,n,lat)            hwxb(m,n) = hwxb(m,n) + hwxbl(m,n,lat)         end do      end do      hw2a(m) = hwxa(m,1) - alpha(1)*hwxa(m,2)      hw2b(m) = hwxb(m,1) - alpha(1)*hwxb(m,2)      hw3a(m) = hwxa(m,3) - alpha(1)*hwxa(m,4)      hw3b(m) = hwxb(m,3) - alpha(1)*hwxb(m,4)      hw2 (m) = hw2a(m) + fixmas*hw2b(m)      hw3 (m) = hw3a(m) + fixmas*hw3b(m)      if(hw3(m) .ne. 0.) then         alpha(m)  = ( hw1(m) - hw2(m) )/hw3(m)      else         alpha(m)  = 1.      end if   end do   do j=beglatex,endlatex      endi = nlonex(j) + i1 - 1      q3(i1:endi,:,ixcldw,j,n3m1) = q3(i1:endi,:,ixcldw,j,n3)   end do   call t_stopf ('scan2_single')   call t_startf ('tfilt_massfix')!$OMP PARALLEL DO PRIVATE (LAT,J)   do lat=beglat,endlat      j = j1 - 1 + lat      call tfilt_massfix (ztodt, lat, u3(i1,1,j,n3m1), v3(i1,1,j,n3m1), t3(i1,1,j,n3m1), &                          q3(i1,1,1,j,n3), q3(i1,1,1,j,n3m1), ps(1,lat,n3m1), cwava(lat), alpha, &                          etamid, qfcst(i1,1,1,lat), div(1,1,lat,n3m1), phis(1,lat), omga(1,1,lat), &                          dpsl(1,lat), dpsm(1,lat), nlon(lat), t3(i1,1,j,n3),beta)   end do   call t_stopf ('tfilt_massfix')!! Shift time pointers!   call shift_time_indices ()   returnend subroutine scan2#ifdef SPMDsubroutine realloc5 (hw2al   ,hw2bl   ,hw3al   ,hw3bl   ,tmass    , &                     hw1lat  ,hwxal   ,hwxbl   ,engy1lat,engy2alat, &                     engy2blat,difftalat,difftblat      )!-----------------------------------------------------------------------!! Purpose:! Reallocation routine for slt variables.!! Author:  J. Rosinski!!-----------------------------------------------------------------------!! $Id: scan2.F90,v 1.11 2001/10/19 17:50:35 eaton Exp $! $Author: eaton $!!-----------------------------------------------------------------------  use precision  use pmgrid  use pspect  use spmd_dyn  use prognostics  use mpishorthand  implicit none#include <comsta.h>!---------------------------------Parameters----------------------------------!  integer, parameter :: msgtype = 5000      ! message passing id!!------------------------------Arguments--------------------------------!  real(r8), intent(in)   :: hw2al (pcnst,plat)   ! -  real(r8), intent(in)   :: hw2bl (pcnst,plat)   !  | lat contributions to components  real(r8), intent(in)   :: hw3al (pcnst,plat)   !  | of tracer global mass integrals   real(r8), intent(in)   :: hw3bl (pcnst,plat)   ! -  real(r8), intent(in)   :: tmass (plat)         !    global atmospheric mass integral  real(r8), intent(in)   :: hw1lat(pcnst,plat)   ! -  real(r8), intent(in)   :: hwxal (pcnst,4,plat) !  | lat contributions to components  real(r8), intent(in)   :: hwxbl (pcnst,4,plat) !  | of tracer global mass integrals !                                                ! -  real(r8), intent(in)   :: engy1lat (plat)      ! lat contribution to total energy (n)  real(r8), intent(in)   :: engy2alat(plat)      ! lat contribution to total energy (n+1)  real(r8), intent(in)   :: engy2blat(plat)      ! lat contribution to total energy (n+1)  real(r8), intent(in)   :: difftalat(plat)      ! lat contribution to delta-T integral  real(r8), intent(in)   :: difftblat(plat)      ! lat contribution to delta-T integral!!---------------------------Local workspace-----------------------------!  integer len  integer procid                                 ! Processor id  integer stat(MPI_STATUS_SIZE)  integer bpos  integer procj,maxcount  integer len_p,beglat_p,numlats_p!!-----------------------------------------------------------------------!! gather global data!  len = numlats*pcnst  do procj=1,ceil2(npes)-1     procid = pair(npes,procj,iam)     if (procid.ge.0) then        bpos = 0        call mpipack (len               ,1      ,mpiint,buf1,bsiz,bpos,mpicom)        call mpipack (beglat            ,1      ,mpiint,buf1,bsiz,bpos,mpicom)        call mpipack (numlats           ,1      ,mpiint,buf1,bsiz,bpos,mpicom)        call mpipack (tmass    (beglat) ,numlats,mpir8 ,buf1,bsiz,bpos,mpicom)        call mpipack (engy1lat (beglat) ,numlats,mpir8 ,buf1,bsiz,bpos,mpicom)        call mpipack (engy2alat(beglat) ,numlats,mpir8 ,buf1,bsiz,bpos,mpicom)        call mpipack (engy2blat(beglat) ,numlats,mpir8 ,buf1,bsiz,bpos,mpicom)        call mpipack (difftalat(beglat) ,numlats,mpir8 ,buf1,bsiz,bpos,mpicom)        call mpipack (difftblat(beglat) ,numlats,mpir8 ,buf1,bsiz,bpos,mpicom)        call mpipack (hw1lat(1  ,beglat),len    ,mpir8 ,buf1,bsiz,bpos,mpicom)        call mpipack (hw2al (1  ,beglat),len    ,mpir8 ,buf1,bsiz,bpos,mpicom)        call mpipack (hw2bl (1  ,beglat),len    ,mpir8 ,buf1,bsiz,bpos,mpicom)        call mpipack (hw3al (1  ,beglat),len    ,mpir8 ,buf1,bsiz,bpos,mpicom)        call mpipack (hw3bl (1  ,beglat),len    ,mpir8 ,buf1,bsiz,bpos,mpicom)        call mpipack (hwxal (1,1,beglat),len*4  ,mpir8 ,buf1,bsiz,bpos,mpicom)        call mpipack (hwxbl (1,1,beglat),len*4  ,mpir8 ,buf1,bsiz,bpos,mpicom)        call mpisendrecv (buf1,bpos,mpipk,procid,msgtype, &                          buf2,bsiz,mpipk,procid,msgtype,mpicom)        bpos = 0        call mpiunpack (buf2,bsiz,bpos,len_p               ,1        ,mpiint,mpicom)        call mpiunpack (buf2,bsiz,bpos,beglat_p            ,1        ,mpiint,mpicom)        call mpiunpack (buf2,bsiz,bpos,numlats_p           ,1        ,mpiint,mpicom)        call mpiunpack (buf2,bsiz,bpos,tmass    (beglat_p) ,numlats_p,mpir8 ,mpicom)        call mpiunpack (buf2,bsiz,bpos,engy1lat (beglat_p) ,numlats_p,mpir8 ,mpicom)        call mpiunpack (buf2,bsiz,bpos,engy2alat(beglat_p) ,numlats_p,mpir8 ,mpicom)        call mpiunpack (buf2,bsiz,bpos,engy2blat(beglat_p) ,numlats_p,mpir8 ,mpicom)        call mpiunpack (buf2,bsiz,bpos,difftalat(beglat_p) ,numlats_p,mpir8 ,mpicom)        call mpiunpack (buf2,bsiz,bpos,difftblat(beglat_p) ,numlats_p,mpir8 ,mpicom)        call mpiunpack (buf2,bsiz,bpos,hw1lat(1  ,beglat_p),len_p    ,mpir8 ,mpicom)        call mpiunpack (buf2,bsiz,bpos,hw2al (1  ,beglat_p),len_p    ,mpir8 ,mpicom)        call mpiunpack (buf2,bsiz,bpos,hw2bl (1  ,beglat_p),len_p    ,mpir8 ,mpicom)        call mpiunpack (buf2,bsiz,bpos,hw3al (1  ,beglat_p),len_p    ,mpir8 ,mpicom)        call mpiunpack (buf2,bsiz,bpos,hw3bl (1  ,beglat_p),len_p    ,mpir8 ,mpicom)        call mpiunpack (buf2,bsiz,bpos,hwxal (1,1,beglat_p),len_p*4  ,mpir8 ,mpicom)        call mpiunpack (buf2,bsiz,bpos,hwxbl (1,1,beglat_p),len_p*4  ,mpir8 ,mpicom)     end if!JR         call mpibarrier(mpicom)  end do  returnend subroutine realloc5#endif