CMM: Vectorization not performed: z1000,psmod,tsmod,psl,phis1
CMAX: [Version 1.0 (6/22/93)]
CMAX: ----------------------------------------------------
CMAX: Transformation of CHGZ1000 from chgz1000.f
CMAX: ----------------------------------------------------
      SUBROUTINE chgz1000(psmod,tsmod,psl,phis1,z1000,pmand,im,jnp,mlev)
      include '/usr/include/cm/CMF_defs.h'
C**********************************************************************
C
C  COMPUTE NEW HEIGHT FIELD AT 1000MB USING ANALYZED SEA LEVEL PRESSURE
C  AND FIRST GUESS SURFACE TEMPERATURE AND PRESSURE.
C
C   PSMOD  - FIRST GUESS SURFACE TEMPERATURE
C   TSMOD  - FIRST GUESS SURFACE PRESSURE
C   PHIS1  - GEOPOTENTIAL (HEIGHT*G)
C   Z1000  - NEW HEIGHT FIELD AT 1000 MB.
C
C**********************************************************************
C
C INPUT ARGUMENTS
      REAL PSMOD (IM, JNP), TSMOD (IM, JNP), PSL (IM, JNP), PHIS1 (IM, J
     &NP), Z1000 (IM, JNP), pmand (MLEV)
C
C PHYSICAL CONSTANTS
      REAL BETA, CP, GRAV, OMEGA2, RADE, RGAS, ROCP, CPOG, GAMMA, ROCP1,
     & GOCP
      COMMON / PHYSIC / BETA, CP, GRAV, OMEGA2, RADE, RGAS, ROCP, CPOG, 
     &GAMMA, ROCP1, GOCP
      REAL KAP, KAP1
!hpf$ distribute phis1(block,block)
!hpf$ distribute pmand(block)
!hpf$ distribute psl(block,block)
!hpf$ distribute psmod(block,block)
!hpf$ distribute tsmod(block,block)
!hpf$ distribute z1000(block,block)
C
C DEFINE CONSTANT KAPPA = ROCP
      kap = rocp
      kap1 = rocp1
C
      betap = .0552
C
C LOOP OVER ALL THE GRID POINTS.
C ---------------------------------------------------------------------
      DO 7004 j = 1 , jnp
        DO 7002 i = 1 , im
C
C Perform the computations looping over all grid points.
C ---------------------------------------------------------------------
          psfg = psmod(i,j)
          tsfg = tsmod(i,j)
          zsurf = phis1(i,j) / grav
          tmid = tsfg + 0.5 * beta * zsurf
C
C COMPUTE NEW SURFACE PRESSURE FROM PSL , REVISE SURFACE TEMPERATURE.
C ---------------------------------------------------------------------
          psurf = psl(i,j) * exp(-grav / rgas * zsurf / tmid)
          tsurf = tsfg + (psurf - psfg) * betap
          tsmod(i,j) = tsurf
C
C FIND A MANDATORY PRESSURE LEVEL JUST BELOW SURFACE.
C ---------------------------------------------------------------------
          DO 7000 l = 1 , mlev
            IF (pmand(l) .GT. psurf) THEN
              GOTO 101
            ENDIF
  100       CONTINUE
 7000     CONTINUE
          l = mlev
C
C COMPUTE 1000MB HEIGHTS .
C ---------------------------------------------------------------------
  101     CONTINUE
          zup = zsurf
          tup = tsurf
          pup = psurf
          pdn = pmand(l)
          IF (abs(pup - pdn) .LT. .01) THEN
            zdn = zup
            GOTO 199
          ENDIF
  102     CONTINUE
          pmidk = (pup ** kap1 - pdn ** kap1) / (kap1 * (pup - pdn))
          pmid = pmidk ** (1. / kap)
          tmid = tup + (pmid - pup) * betap
          zdn = zup + cpog * tmid * (pup ** kap - pdn ** kap) / pmidk
  199     CONTINUE
          IF (l .LT. mlev) THEN
            tup = tup + (pdn - pup) * betap
            pup = pdn
            zup = zdn
            l = l + 1
            pdn = pmand(l)
            GOTO 102
          ENDIF
          z1000(i,j) = zdn
  200     CONTINUE
 7002   CONTINUE
 7004 CONTINUE
      RETURN
      END
