CALPW.f

Go to the documentation of this file.

 
      SUBROUTINE calpw(PW,IDECID)
 
!     
      use vrbls3d,    only: q, qqw, qqi, qqr, qqs, cwm, qqg, t, rswtt,    &
                            train, tcucn, mcvg, pmid, o3, ext, pint, rlwtt, &
                            taod5503d,sca, asy
      use vrbls4d,    only: smoke
      use masks,      only: htm
      use params_mod, only: tfrz, gi
      use ctlblk_mod, only: lm, jsta, jend, im, spval, ista, iend
      use upp_physics, only: fpvsnew
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      implicit none
!     
!     
!     SET DENSITY OF WATER AT 1 ATMOSPHERE PRESSURE, 0C.
!     UNITS ARE KG/M**3.
      real,PARAMETER :: RHOWAT=1.e3
      real,parameter:: con_rd      =2.8705e+2 ! gas constant air    (J/kg/K)
      real,parameter:: con_rv      =4.6150e+2 ! gas constant H2O
      real,parameter:: con_eps     =con_rd/con_rv
      real,parameter:: con_epsm1   =con_rd/con_rv-1
!     
!     DECLARE VARIABLES.
!     
      integer,intent(in)  ::  IDECID
      real,dimension(ista:iend,jsta:jend),intent(inout) :: PW
      INTEGER LLMH,I,J,L
      REAL ALPM,DZ,PM,PWSUM,RHOAIR,DP,ES
      REAL QDUM(ista:iend,jsta:jend), PWS(ista:iend,jsta:jend),QS(ista:iend,jsta:jend)
!
!***************************************************************
!     START CALPW HERE.
!
!     INITIALIZE PW TO 0.    
!     
!$omp  parallel do private(i,j)
      DO j=jsta,jend
        DO i=ista,iend
          pw(i,j)  = 0.
          pws(i,j) = 0.
        ENDDO
      ENDDO
!     
!     OUTER LOOP OVER VERTICAL DIMENSION.
!     INNER LOOP OVER HORIZONTAL GRID.
!     
!!$omp  parallel do private(i,j,l,es,dp)
      DO l = 1,lm
        IF (idecid <= 1) THEN
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = q(i,j,l)
            ENDDO
          ENDDO
        ELSE IF (idecid == 2) THEN
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = qqw(i,j,l)
            ENDDO
          ENDDO
        ELSE IF (idecid == 3) THEN
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = qqi(i,j,l)
            ENDDO
          ENDDO
        ELSE IF (idecid == 4) THEN
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = qqr(i,j,l)
            ENDDO
          ENDDO
        ELSE IF (idecid == 5) THEN
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = qqs(i,j,l)
            ENDDO
          ENDDO
        ELSE IF (idecid == 6) THEN
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = cwm(i,j,l)
            ENDDO
          ENDDO
! SRD
        ELSE IF (idecid == 16) THEN
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = qqg(i,j,l)
            ENDDO
          ENDDO
! SRD
        ELSE IF (idecid == 7) THEN
!-- Total supercooled liquid
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              IF (t(i,j,l) >= tfrz) THEN
                qdum(i,j) = 0.
              ELSE
                qdum(i,j) = qqw(i,j,l) + qqr(i,j,l)
              ENDIF
            ENDDO
          ENDDO
        ELSE IF (idecid == 8) THEN
!-- Total melting ice
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              IF (t(i,j,l) <= tfrz) THEN
                qdum(i,j) = 0.
              ELSE
                qdum(i,j) = qqi(i,j,l) + qqs(i,j,l)
              ENDIF
            ENDDO
          ENDDO
        ELSE IF (idecid == 9) THEN
! SHORT WAVE T TENDENCY
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = rswtt(i,j,l)
            ENDDO
          ENDDO
        ELSE IF (idecid == 10) THEN
! LONG WAVE T TENDENCY
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = rlwtt(i,j,l)
            ENDDO
          ENDDO  
        ELSE IF (idecid == 11) THEN
! LATENT HEATING FROM GRID SCALE RAIN/EVAP
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = train(i,j,l)
            ENDDO
          ENDDO  
        ELSE IF (idecid == 12) THEN
! LATENT HEATING FROM CONVECTION
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = tcucn(i,j,l)
            ENDDO
          ENDDO
        ELSE IF (idecid == 13) THEN
! MOISTURE CONVERGENCE
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = mcvg(i,j,l)
            ENDDO
          ENDDO
! RH
        ELSE IF (idecid == 14) THEN
!$omp  parallel do private(i,j,es)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = q(i,j,l)
              es        = min(fpvsnew(t(i,j,l)),pmid(i,j,l))
              qs(i,j)   = con_eps*es/(pmid(i,j,l)+con_epsm1*es)
            ENDDO
          END DO
! OZONE
        ELSE IF (idecid == 15) THEN
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = o3(i,j,l)
            ENDDO
          END DO
 
! AEROSOL EXTINCTION (GOCART)
        ELSE IF (idecid == 17) THEN
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = ext(i,j,l)
            ENDDO
          END DO
!
! E. James - 8 Dec 2017
! FIRE SMOKE (tracer_1a FROM HRRR-SMOKE)
        ELSE IF (idecid == 18) THEN
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = smoke(i,j,l,1)/1000000000.
            ENDDO
          END DO
!
! E. James - 8 Dec 2017
! HRRR-SMOKE AOD
        ELSE IF (idecid == 19) THEN
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = taod5503d(i,j,l)
            ENDDO
          END DO
!LZhang -July 2019
! SCATTERING AEROSOL OPTICAL THICKNESS (GOCART V2)
        ELSE IF (idecid == 20) THEN
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = sca(i,j,l)
            ENDDO
          END DO
 
! ASYMMETRY PARAMETER (GOCART V2)
        ELSE IF (idecid == 21) THEN
!$omp  parallel do private(i,j)
          DO j=jsta,jend
            DO i=ista,iend
              qdum(i,j) = asy(i,j,l)
            ENDDO
          END DO
        ENDIF
!
!$omp  parallel do private(i,j,dp)
        DO j=jsta,jend
          DO i=ista,iend
            if(pint(i,j,l+1) <spval .and. qdum(i,j) < spval) then
             dp      = pint(i,j,l+1) - pint(i,j,l)
            IF (idecid == 19) THEN
             pw(i,j) = pw(i,j) + qdum(i,j)
        ELSE
         pw(i,j) = pw(i,j) + qdum(i,j)*max(dp,0.)*gi*htm(i,j,l)
            ENDIF
            IF (idecid == 14) pws(i,j) = pws(i,j) + qs(i,j)*dp*gi*htm(i,j,l)
            else
             pw(i,j) = spval
             pws(i,j) = spval
            endif
          ENDDO
        ENDDO
      ENDDO                 ! l loop
 
      
      IF (idecid == 14)THEN
!$omp  parallel do private(i,j)
        DO j=jsta,jend
          DO i=ista,iend
            if( pw(i,j)<spval) then
            pw(i,j) = max(0.,pw(i,j)/pws(i,j)*100.) 
            endif
          ENDDO
        ENDDO
      END IF
!  convert ozone from kg/m2 to dobson units, which give the depth of the
!  ozone layer in 1e-5 m if brought to natural temperature and pressure.    
 
      IF (idecid == 15) then
!$omp  parallel do private(i,j)
        DO j=jsta,jend
          DO i=ista,iend
            if( pw(i,j)<spval) then
            pw(i,j) = pw(i,j) / 2.14e-5
            endif
          ENDDO
        ENDDO
      endif
!
!     END OF ROUTINE.
!     
      RETURN
      END