wrftladj/module_physics_addtendc_ad.F

   1 !WRF:MODEL_LAYER: PHYSICS
   2 !
   3 ! note: this module really belongs in the dyn_em directory since it is
   4 !       specific only to the EM core. Leaving here for now, with an
   5 !       #if ( EM_CORE == 1 ) directive. JM 20031201
   6 !
   7
   8 !  This MODULE holds the routines which are used to perform updates of the
   9 !  model C-grid tendencies with physics A-grid tendencies
  10 !  The module consolidates code that was (up to v1.2) duplicated in
  11 !  module_em and module_rk and in
  12 !  module_big_step_utilities.F and module_big_step_utilities_em.F
  13
  14 !  This MODULE CONTAINS the following routines:
  15 !  update_phy_ten, phy_ra_ten, phy_bl_ten, phy_cu_ten, advance_ppt,
  16 !  add_a2a, add_a2c_u, and add_a2c_v
  17
  18
  19 MODULE a_module_physics_addtendc
  20
  21 #if ( EM_CORE == 1 )
  22
  23    USE module_state_description
  24    USE module_configure
  25
  26 CONTAINS
  27
  28 SUBROUTINE a_update_phy_ten(rph_tendf,rt_tendf,a_rt_tendf,ru_tendf,a_ru_tendf,  &
  29                       rv_tendf,a_rv_tendf,moist_tendf,a_moist_tendf,        &
  30                       scalar_tendf,mu_tendf,                                &
  31                       RTHRATEN,RTHBLTEN,a_RTHBLTEN,RTHCUTEN,a_RTHCUTEN,RTHSHTEN,       &
  32                       RUBLTEN,a_RUBLTEN,RUCUTEN,RUSHTEN,                    &
  33                       RVBLTEN,a_RVBLTEN,RVCUTEN,RVSHTEN,                    &
  34                       RQVBLTEN,a_RQVBLTEN,RQCBLTEN,RQIBLTEN,                &
  35                       RQVCUTEN,a_RQVCUTEN,RQCCUTEN,RQRCUTEN,RQICUTEN,RQSCUTEN,         &
  36                       RQVSHTEN,RQCSHTEN,RQRSHTEN,RQISHTEN,RQSSHTEN,RQGSHTEN,&
  37                       RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RPHNDGDTEN,            &
  38                       RQVNDGDTEN,RMUNDGDTEN,                                &
  39                       rthfrten,rqvfrten,                                    & !fire
  40                       n_moist,n_scalar,config_flags,rk_step,adv_moist_cond, &
  41                       ids, ide, jds, jde, kds, kde,                         &
  42                       ims, ime, jms, jme, kms, kme,                         &
  43                       its, ite, jts, jte, kts, kte                          )
  44 !-------------------------------------------------------------------
  45    IMPLICIT NONE
  46 !-------------------------------------------------------------------
  47
  48    TYPE(grid_config_rec_type   ) ,   INTENT(IN   ) :: config_flags
  49
  50    INTEGER , INTENT(IN)        ::  ids, ide, jds, jde, kds, kde,   &
  51                                    ims, ime, jms, jme, kms, kme,   &
  52                                    its, ite, jts, jte, kts, kte,   &
  53                                    n_moist,n_scalar,rk_step
  54
  55    LOGICAL , INTENT(IN)        :: adv_moist_cond
  56
  57    REAL , DIMENSION(ims:ime , kms:kme, jms:jme),INTENT(INOUT) ::   &
  58                                                          ru_tendf, &
  59                                                        a_ru_tendf, &
  60                                                          rv_tendf, &
  61                                                        a_rv_tendf, &
  62                                                          rt_tendf, &
  63                                                        a_rt_tendf, &
  64                                                          rph_tendf
  65
  66    REAL , DIMENSION(ims:ime , jms:jme),INTENT(INOUT) ::  mu_tendf
  67
  68    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_moist),           &
  69           INTENT(INOUT)     ::                        moist_tendf, &
  70                                                     a_moist_tendf
  71
  72    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_scalar),           &
  73           INTENT(INOUT)     ::                        scalar_tendf
  74
  75    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN  ) ::   &
  76                                                        RTHRATEN, &
  77                                                        RTHBLTEN, &
  78                                                        RTHCUTEN, &
  79                                                        RTHSHTEN, &
  80                                                         RUBLTEN, &
  81                                                         RUCUTEN, &
  82                                                         RUSHTEN, &
  83                                                         RVBLTEN, &
  84                                                         RVCUTEN, &
  85                                                         RVSHTEN, &
  86                                                        RQVBLTEN, &
  87                                                        RQCBLTEN, &
  88                                                        RQIBLTEN, &
  89                                                        RQVCUTEN, &
  90                                                        RQCCUTEN, &
  91                                                        RQRCUTEN, &
  92                                                        RQICUTEN, &
  93                                                        RQSCUTEN, &
  94                                                        RQVSHTEN, &
  95                                                        RQCSHTEN, &
  96                                                        RQRSHTEN, &
  97                                                        RQISHTEN, &
  98                                                        RQSSHTEN, &
  99                                                        RQGSHTEN, &
 100                                                      RTHNDGDTEN, &
 101                                                      RPHNDGDTEN, &
 102                                                      RQVNDGDTEN, &
 103                                                       RUNDGDTEN, &
 104                                                       RVNDGDTEN
 105
 106    REAL, DIMENSION(ims:ime, kms:kme, jms:jme) ::   &
 107                                                      a_RTHBLTEN, &
 108                                                      a_RTHCUTEN, &
 109                                                       a_RUBLTEN, &
 110                                                       a_RVBLTEN, &
 111                                                      a_RQVBLTEN, &
 112                                                      a_RQVCUTEN
 113
 114    REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN  ) :: RMUNDGDTEN
 115
 116    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN  ) ::   & ! fire
 117                                                        rthfrten, &
 118                                                        rqvfrten
 119 !------------------------------------------------------------------
 120 !  set up loop bounds for this grid's boundary conditions
 121
 122    if (config_flags%cu_physics .gt. 0)                         &
 123       CALL a_phy_cu_ten(config_flags,rk_step,n_moist,n_scalar,   &
 124                       rt_tendf,a_rt_tendf,ru_tendf,rv_tendf,   &
 125                       RUCUTEN,RVCUTEN,RTHCUTEN,a_RTHCUTEN,     &
 126                       RQVCUTEN,a_RQVCUTEN,RQCCUTEN,RQRCUTEN,   &
 127                       RQICUTEN,RQSCUTEN,moist_tendf,a_moist_tendf,&
 128                       scalar_tendf,adv_moist_cond,             &
 129                       ids, ide, jds, jde, kds, kde,            &
 130                       ims, ime, jms, jme, kms, kme,            &
 131                       its, ite, jts, jte, kts, kte             )
 132
 133    if (config_flags%bl_pbl_physics .gt. 0)                     &
 134       CALL a_phy_bl_ten(config_flags,rk_step,n_moist,n_scalar,   &
 135                       rt_tendf,a_rt_tendf,ru_tendf,a_ru_tendf,   &
 136                       rv_tendf,a_rv_tendf,moist_tendf,a_moist_tendf, &
 137                       scalar_tendf,adv_moist_cond,             &
 138                       RTHBLTEN,a_RTHBLTEN,RUBLTEN,a_RUBLTEN,   &
 139                       RVBLTEN,a_RVBLTEN,                       &
 140                       RQVBLTEN,a_RQVBLTEN,RQCBLTEN,RQIBLTEN,   &
 141                       ids, ide, jds, jde, kds, kde,            &
 142                       ims, ime, jms, jme, kms, kme,            &
 143                       its, ite, jts, jte, kts, kte             )
 144
 145 END SUBROUTINE a_update_phy_ten
 146
 147 !=================================================================
 148 SUBROUTINE a_phy_bl_ten(config_flags,rk_step,n_moist,n_scalar,     &
 149                       rt_tendf,a_rt_tendf,ru_tendf,a_ru_tendf,     &
 150                       rv_tendf,a_rv_tendf,moist_tendf,a_moist_tendf, &
 151                       scalar_tendf,adv_moist_cond,               &
 152                       RTHBLTEN,a_RTHBLTEN,RUBLTEN,a_RUBLTEN,     &
 153                       RVBLTEN,a_RVBLTEN,                         &
 154                       RQVBLTEN,a_RQVBLTEN,RQCBLTEN,RQIBLTEN,     &
 155                       ids, ide, jds, jde, kds, kde,              &
 156                       ims, ime, jms, jme, kms, kme,              &
 157                       its, ite, jts, jte, kts, kte               )
 158 !-----------------------------------------------------------------
 159    IMPLICIT NONE
 160 !-----------------------------------------------------------------
 161    TYPE(grid_config_rec_type) ,     INTENT(IN   ) :: config_flags
 162
 163    INTEGER , INTENT(IN)        ::  ids, ide, jds, jde, kds, kde, &
 164                                    ims, ime, jms, jme, kms, kme, &
 165                                    its, ite, jts, jte, kts, kte, &
 166                                    n_moist, n_scalar, rk_step
 167
 168    LOGICAL , INTENT(IN)     :: adv_moist_cond
 169
 170    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_moist),         &
 171           INTENT(INOUT)     ::                      moist_tendf, &
 172                                                   a_moist_tendf
 173
 174    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_scalar),         &
 175           INTENT(INOUT)     ::                      scalar_tendf
 176
 177    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN  ) ::   &
 178                                                        RTHBLTEN, &
 179                                                         RUBLTEN, &
 180                                                         RVBLTEN, &
 181                                                        RQVBLTEN, &
 182                                                        RQCBLTEN, &
 183                                                        RQIBLTEN
 184
 185    REAL, DIMENSION(ims:ime, kms:kme, jms:jme) ::   &
 186                                                      a_RTHBLTEN, &
 187                                                       a_RUBLTEN, &
 188                                                       a_RVBLTEN, &
 189                                                      a_RQVBLTEN
 190
 191    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT)::   &
 192                                                        rt_tendf, &
 193                                                      a_rt_tendf, &
 194                                                        ru_tendf, &
 195                                                      a_ru_tendf, &
 196                                                        rv_tendf, &
 197                                                      a_rv_tendf
 198 ! LOCAL VARS
 199
 200    INTEGER :: i,j,k,IBGN,IEND,JBGN,JEND
 201
 202 !-----------------------------------------------------------------
 203
 204    SELECT CASE(config_flags%bl_pbl_physics)
 205
 206       CASE (SURFDRAGSCHEME)
 207
 208            if (P_QV .ge. PARAM_FIRST_SCALAR)                                         &
 209               CALL a_add_a2a(moist_tendf(ims,kms,jms,P_QV),      &
 210                    a_moist_tendf(ims,kms,jms,P_QV),              &
 211                    RQVBLTEN, a_RQVBLTEN,                         &
 212                    config_flags,                                 &
 213                    ids,ide, jds, jde, kds, kde,                  &
 214                    ims, ime, jms, jme, kms, kme,                 &
 215                    its, ite, jts, jte, kts, kte                  )
 216
 217            CALL a_add_a2c_v(rv_tendf,a_rv_tendf,                 &
 218                 RVBLTEN,a_RVBLTEN,config_flags,                  &
 219                 ids,ide, jds, jde, kds, kde,                     &
 220                 ims, ime, jms, jme, kms, kme,                    &
 221                 its, ite, jts, jte, kts, kte                     )
 222
 223            CALL a_add_a2c_u(ru_tendf,a_ru_tendf,                 &
 224                 RUBLTEN,a_RUBLTEN,config_flags,                  &
 225                 ids,ide, jds, jde, kds, kde,                     &
 226                 ims, ime, jms, jme, kms, kme,                    &
 227                 its, ite, jts, jte, kts, kte                     )
 228
 229            CALL a_add_a2a(rt_tendf,a_rt_tendf,                 &
 230                 RTHBLTEN,a_RTHBLTEN,config_flags,                  &
 231                 ids,ide, jds, jde, kds, kde,                     &
 232                 ims, ime, jms, jme, kms, kme,                    &
 233                 its, ite, jts, jte, kts, kte                     )
 234
 235       CASE DEFAULT
 236
 237        print*,'a_phy_bl_ten: The pbl scheme does not exist'
 238
 239    END SELECT
 240
 241 END SUBROUTINE a_phy_bl_ten
 242
 243 SUBROUTINE a_phy_cu_ten(config_flags,rk_step,n_moist,n_scalar,     &
 244                       rt_tendf,a_rt_tendf,ru_tendf,rv_tendf,     &
 245                       RUCUTEN,RVCUTEN,RTHCUTEN,a_RTHCUTEN,       &
 246                       RQVCUTEN,a_RQVCUTEN,RQCCUTEN,RQRCUTEN,     &
 247                       RQICUTEN,RQSCUTEN,moist_tendf,a_moist_tendf,&
 248                       scalar_tendf,adv_moist_cond,               &
 249                       ids, ide, jds, jde, kds, kde,              &
 250                       ims, ime, jms, jme, kms, kme,              &
 251                       its, ite, jts, jte, kts, kte               )
 252 !-----------------------------------------------------------------
 253    IMPLICIT NONE
 254 !-----------------------------------------------------------------
 255    TYPE(grid_config_rec_type  ) , INTENT(IN   ) :: config_flags
 256
 257    INTEGER , INTENT(IN)        ::  ids, ide, jds, jde, kds, kde, &
 258                                    ims, ime, jms, jme, kms, kme, &
 259                                    its, ite, jts, jte, kts, kte, &
 260                                    n_moist, n_scalar, rk_step
 261
 262    LOGICAL , INTENT(IN)     :: adv_moist_cond
 263
 264    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_moist),         &
 265           INTENT(INOUT)     ::                      moist_tendf, a_moist_tendf
 266
 267    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_scalar),         &
 268           INTENT(INOUT)     ::                      scalar_tendf
 269
 270    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN  ) ::   &
 271                                                         RUCUTEN, &
 272                                                         RVCUTEN, &
 273                                                        RTHCUTEN, &
 274                                                        RQVCUTEN, &
 275                                                        RQCCUTEN, &
 276                                                        RQRCUTEN, &
 277                                                        RQICUTEN, &
 278                                                        RQSCUTEN
 279
 280    REAL, DIMENSION(ims:ime, kms:kme, jms:jme) ::   &
 281                                                      a_RTHCUTEN, &
 282                                                      a_RQVCUTEN
 283
 284    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::  &
 285                                                        rt_tendf, &
 286                                                      a_rt_tendf, &
 287                                                        ru_tendf, &
 288                                                        rv_tendf
 289
 290
 291 ! LOCAL VARS
 292
 293    INTEGER :: i,j,k
 294
 295    SELECT CASE (config_flags%cu_physics)
 296
 297    CASE (DUCUSCHEME)
 298         CALL a_add_a2a(rt_tendf, a_rt_tendf,                     &
 299                 RTHCUTEN, a_RTHCUTEN, config_flags,              &
 300                 ids,ide, jds, jde, kds, kde,                     &
 301                 ims, ime, jms, jme, kms, kme,                    &
 302                 its, ite, jts, jte, kts, kte                     )
 303
 304         if (P_QV .ge. PARAM_FIRST_SCALAR)                                         &
 305         CALL a_add_a2a(moist_tendf(ims,kms,jms,P_QV),            &
 306                 a_moist_tendf(ims,kms,jms,P_QV), RQVCUTEN,       &
 307                 a_RQVCUTEN,                                      &
 308                 config_flags,                                    &
 309                 ids,ide, jds, jde, kds, kde,                     &
 310                 ims, ime, jms, jme, kms, kme,                    &
 311                 its, ite, jts, jte, kts, kte                     )
 312
 313    CASE DEFAULT
 314
 315    END SELECT
 316
 317 END SUBROUTINE a_phy_cu_ten
 318
 319
 320 !        Generated by TAPENADE     (INRIA, Tropics team)
 321 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
 322 !
 323 !  Differentiation of advance_ppt in reverse (adjoint) mode:
 324 !   gradient     of useful results: pratesh rqccuten rthcuten rqicuten
 325 !                rqscuten rainc pratec cuppt cutop cubot nca rqrcuten
 326 !                rqvcuten rainsh htop hbot
 327 !   with respect to varying inputs: pratesh rqccuten rthcuten rqicuten
 328 !                rqscuten rainc pratec cuppt cutop cubot nca rqrcuten
 329 !                rqvcuten rainsh htop hbot
 330 !   RW status of diff variables: pratesh:incr rqccuten:in-out rthcuten:in-out
 331 !                rqicuten:in-out rqscuten:in-out rainc:in-out pratec:incr
 332 !                cuppt:in-out cutop:incr cubot:incr nca:in-out
 333 !                rqrcuten:in-out rqvcuten:in-out rainsh:in-out
 334 !                htop:in-out hbot:in-out
 335 SUBROUTINE A_ADVANCE_PPT(rthcuten, rthcutenb, rqvcuten, rqvcutenb, &
 336 &  rqccuten, rqccutenb, rqrcuten, rqrcutenb, rqicuten, rqicutenb, &
 337 &  rqscuten, rqscutenb, rainc, raincb, raincv, rainsh, rainshb, pratec, &
 338 &  pratecb, pratesh, prateshb, nca, ncab, htop, htopb, hbot, hbotb, cutop&
 339 &  , cutopb, cubot, cubotb, cuppt, cupptb, dt, config_flags, ids, ide, &
 340 &  jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, &
 341 &  kts, kte)
 342   IMPLICIT NONE
 343 !
 344   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
 345   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
 346 &  jme, kms, kme, its, ite, jts, jte, kts, kte
 347   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthcuten&
 348 &  , rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten
 349   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rthcutenb, rqvcutenb, &
 350 &  rqccutenb, rqrcutenb, rqicutenb, rqscutenb
 351   REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: rainc, rainsh, &
 352 &  raincv, pratec, pratesh, nca, htop, hbot, cutop, cubot, cuppt
 353   REAL, DIMENSION(ims:ime, jms:jme) :: raincb, rainshb, pratecb, &
 354 &  prateshb, ncab, htopb, hbotb, cutopb, cubotb, cupptb
 355   REAL, INTENT(IN) :: dt
 356 ! LOCAL  VAR
 357   INTEGER :: i, j, k, i_start, i_end, j_start, j_end, k_start, k_end
 358   INTEGER :: ncutop, ncubot
 359   INTEGER :: branch
 360   REAL :: tempb
 361 !-----------------------------------------------------------------
 362   IF (config_flags%cu_physics .NE. 0) THEN
 363 ! SET START AND END POINTS FOR TILES
 364     i_start = its
 365     IF (ite .GT. ide - 1) THEN
 366       i_end = ide - 1
 367     ELSE
 368       i_end = ite
 369     END IF
 370     j_start = jts
 371     IF (jte .GT. jde - 1) THEN
 372       j_end = jde - 1
 373     ELSE
 374       j_end = jte
 375     END IF
 376 !
 377 !  IF( config_flags%nested .or. config_flags%specified ) THEN
 378 !    i_start = max( its,ids+1 )
 379 !    i_end   = min( ite,ide-2 )
 380 !    j_start = max( jts,jds+1 )
 381 !    j_end   = min( jte,jde-2 )
 382 !  ENDIF
 383 !
 384     k_start = kts
 385     IF (kte .GT. kde - 1) THEN
 386       k_end = kde - 1
 387     ELSE
 388       k_end = kte
 389     END IF
 390     SELECT CASE  (config_flags%cu_physics)
 391     CASE (kfscheme)
 392       DO j=j_start,j_end
 393         DO i=i_start,i_end
 394           IF (nca(i, j) .GT. 0) THEN
 395             IF (NINT(nca(i, j)/dt) .LE. 0) THEN
 396 ! set tendency to zero
 397 !                PRATEC(I,J)=0.
 398 !                RAINCV(I,J)=0.
 399               DO k=k_start,k_end
 400                 IF (p_qi .GE. param_first_scalar) THEN
 401                   CALL PUSHCONTROL1B(0)
 402                 ELSE
 403                   CALL PUSHCONTROL1B(1)
 404                 END IF
 405                 IF (p_qs .GE. param_first_scalar) THEN
 406                   CALL PUSHCONTROL1B(1)
 407                 ELSE
 408                   CALL PUSHCONTROL1B(0)
 409                 END IF
 410               END DO
 411               CALL PUSHCONTROL2B(1)
 412             ELSE
 413               CALL PUSHCONTROL2B(2)
 414             END IF
 415           ELSE
 416             CALL PUSHCONTROL2B(0)
 417           END IF
 418         END DO
 419       END DO
 420       DO j=j_end,j_start,-1
 421         DO i=i_end,i_start,-1
 422           CALL POPCONTROL2B(branch)
 423           IF (branch .NE. 0) THEN
 424             IF (branch .EQ. 1) THEN
 425               DO k=k_end,k_start,-1
 426                 CALL POPCONTROL1B(branch)
 427                 IF (branch .NE. 0) rqscutenb(i, k, j) = 0.0
 428                 CALL POPCONTROL1B(branch)
 429                 IF (branch .EQ. 0) rqicutenb(i, k, j) = 0.0
 430                 rqrcutenb(i, k, j) = 0.0
 431                 rqccutenb(i, k, j) = 0.0
 432                 rqvcutenb(i, k, j) = 0.0
 433                 rthcutenb(i, k, j) = 0.0
 434               END DO
 435             END IF
 436           END IF
 437         END DO
 438       END DO
 439     CASE (ducuscheme)
 440 !
 441       DO j=j_start,j_end
 442         DO i=i_start,i_end
 443           IF (nca(i, j) .GT. 0) THEN
 444             IF (NINT(nca(i, j)/dt) .LE. 0) THEN
 445               CALL PUSHCONTROL2B(1)
 446             ELSE
 447               CALL PUSHCONTROL2B(2)
 448             END IF
 449           ELSE
 450             CALL PUSHCONTROL2B(0)
 451           END IF
 452         END DO
 453       END DO
 454       DO j=j_end,j_start,-1
 455         DO i=i_end,i_start,-1
 456           CALL POPCONTROL2B(branch)
 457           IF (branch .NE. 0) THEN
 458             IF (branch .EQ. 1) THEN
 459               DO k=k_end,k_start,-1
 460                 rqvcutenb(i, k, j) = 0.0
 461                 rthcutenb(i, k, j) = 0.0
 462               END DO
 463             END IF
 464           END IF
 465         END DO
 466       END DO
 467     CASE (bmjscheme, camzmscheme)
 468 !
 469       DO j=j_start,j_end
 470         DO i=i_start,i_end
 471 ! HTOP, HBOT FOR GFDL RADIATION
 472           ncutop = NINT(cutop(i, j))
 473           ncubot = NINT(cubot(i, j))
 474           IF (ncutop .GT. 1 .AND. ncutop .LT. kde) THEN
 475             IF (cutop(i, j) .LT. htop(i, j)) THEN
 476               CALL PUSHCONTROL2B(2)
 477             ELSE
 478               CALL PUSHCONTROL2B(1)
 479             END IF
 480           ELSE
 481             CALL PUSHCONTROL2B(0)
 482           END IF
 483           IF (ncubot .GT. 0 .AND. ncubot .LT. kde) THEN
 484             IF (cubot(i, j) .GT. hbot(i, j)) THEN
 485               CALL PUSHCONTROL2B(1)
 486             ELSE
 487               CALL PUSHCONTROL2B(2)
 488             END IF
 489           ELSE
 490             CALL PUSHCONTROL2B(0)
 491           END IF
 492         END DO
 493       END DO
 494       DO j=j_end,j_start,-1
 495         DO i=i_end,i_start,-1
 496           CALL POPCONTROL2B(branch)
 497           IF (branch .NE. 0) THEN
 498             IF (branch .NE. 1) THEN
 499               cubotb(i, j) = cubotb(i, j) + hbotb(i, j)
 500               hbotb(i, j) = 0.0
 501             END IF
 502           END IF
 503           CALL POPCONTROL2B(branch)
 504           IF (branch .NE. 0) THEN
 505             IF (branch .EQ. 1) THEN
 506               cutopb(i, j) = cutopb(i, j) + htopb(i, j)
 507               htopb(i, j) = 0.0
 508             END IF
 509           END IF
 510         END DO
 511       END DO
 512     CASE (kfetascheme, MSKFSCHEME)
 513       DO j=j_start,j_end
 514         DO i=i_start,i_end
 515 ! HTOP, HBOT FOR GFDL RADIATION
 516           ncutop = NINT(cutop(i, j))
 517           ncubot = NINT(cubot(i, j))
 518           IF (ncutop .GT. 1 .AND. ncutop .LT. kde) THEN
 519             IF (cutop(i, j) .LT. htop(i, j)) THEN
 520               CALL PUSHCONTROL2B(2)
 521             ELSE
 522               CALL PUSHCONTROL2B(1)
 523             END IF
 524           ELSE
 525             CALL PUSHCONTROL2B(0)
 526           END IF
 527           IF (ncubot .GT. 0 .AND. ncubot .LT. kde) THEN
 528             IF (cubot(i, j) .GT. hbot(i, j)) THEN
 529               CALL PUSHCONTROL2B(2)
 530             ELSE
 531               CALL PUSHCONTROL2B(1)
 532             END IF
 533           ELSE
 534             CALL PUSHCONTROL2B(0)
 535           END IF
 536           IF (nca(i, j) .GT. 0) THEN
 537             IF (NINT(nca(i, j)/dt) .LE. 1) THEN
 538 ! set tendency to zero
 539 !                PRATEC(I,J)=0.
 540 !                RAINCV(I,J)=0.
 541               DO k=k_start,k_end
 542                 IF (p_qi .GE. param_first_scalar) THEN
 543                   CALL PUSHCONTROL1B(0)
 544                 ELSE
 545                   CALL PUSHCONTROL1B(1)
 546                 END IF
 547                 IF (p_qs .GE. param_first_scalar) THEN
 548                   CALL PUSHCONTROL1B(1)
 549                 ELSE
 550                   CALL PUSHCONTROL1B(0)
 551                 END IF
 552               END DO
 553               CALL PUSHCONTROL2B(1)
 554             ELSE
 555               CALL PUSHCONTROL2B(2)
 556             END IF
 557           ELSE
 558             CALL PUSHCONTROL2B(0)
 559           END IF
 560         END DO
 561       END DO
 562       DO j=j_end,j_start,-1
 563         DO i=i_end,i_start,-1
 564           CALL POPCONTROL2B(branch)
 565           IF (branch .NE. 0) THEN
 566             IF (branch .EQ. 1) THEN
 567               DO k=k_end,k_start,-1
 568                 CALL POPCONTROL1B(branch)
 569                 IF (branch .NE. 0) rqscutenb(i, k, j) = 0.0
 570                 CALL POPCONTROL1B(branch)
 571                 IF (branch .EQ. 0) rqicutenb(i, k, j) = 0.0
 572                 rqrcutenb(i, k, j) = 0.0
 573                 rqccutenb(i, k, j) = 0.0
 574                 rqvcutenb(i, k, j) = 0.0
 575                 rthcutenb(i, k, j) = 0.0
 576               END DO
 577             END IF
 578           END IF
 579           CALL POPCONTROL2B(branch)
 580           IF (branch .NE. 0) THEN
 581             IF (branch .EQ. 1) THEN
 582               cubotb(i, j) = cubotb(i, j) + hbotb(i, j)
 583               hbotb(i, j) = 0.0
 584             END IF
 585           END IF
 586           CALL POPCONTROL2B(branch)
 587           IF (branch .NE. 0) THEN
 588             IF (branch .EQ. 1) THEN
 589               cutopb(i, j) = cutopb(i, j) + htopb(i, j)
 590               htopb(i, j) = 0.0
 591             END IF
 592           END IF
 593         END DO
 594       END DO
 595     END SELECT
 596     DO j=j_end,j_start,-1
 597       DO i=i_end,i_start,-1
 598         tempb = dt*cupptb(i, j)/1000.
 599         pratecb(i, j) = pratecb(i, j) + dt*raincb(i, j) + tempb
 600         prateshb(i, j) = prateshb(i, j) + dt*rainshb(i, j) + tempb
 601       END DO
 602     END DO
 603   END IF
 604 END SUBROUTINE A_ADVANCE_PPT
 605
 606 !        Generated by TAPENADE     (INRIA, Tropics team)
 607 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
 608 !
 609 !  Differentiation of add_a2a in reverse (adjoint) mode:
 610 !   gradient     of useful results: lvar rvar
 611 !   with respect to varying inputs: lvar rvar
 612 !   RW status of diff variables: lvar:in-out rvar:incr
 613 SUBROUTINE A_ADD_A2A(lvar, lvarb, rvar, rvarb, config_flags, ids, ide, &
 614 &  jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, &
 615 &  kts, kte)
 616   IMPLICIT NONE
 617 !------------------------------------------------------------
 618   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
 619   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
 620 &  jme, kms, kme, its, ite, jts, jte, kts, kte
 621   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rvar
 622   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rvarb
 623   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: lvar
 624   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: lvarb
 625 ! LOCAL VARS
 626   INTEGER :: i, j, k, i_start, i_end, j_start, j_end, ktf
 627   INTRINSIC MAX
 628   INTRINSIC MIN
 629   i_start = its
 630   IF (ite .GT. ide - 1) THEN
 631     i_end = ide - 1
 632   ELSE
 633     i_end = ite
 634   END IF
 635   j_start = jts
 636   IF (jte .GT. jde - 1) THEN
 637     j_end = jde - 1
 638   ELSE
 639     j_end = jte
 640   END IF
 641   IF (kte .GT. kde - 1) THEN
 642     ktf = kde - 1
 643   ELSE
 644     ktf = kte
 645   END IF
 646   IF (config_flags%specified .OR. config_flags%nested) THEN
 647     IF (ids + 1 .LT. its) THEN
 648       i_start = its
 649     ELSE
 650       i_start = ids + 1
 651     END IF
 652   END IF
 653   IF (config_flags%specified .OR. config_flags%nested) THEN
 654     IF (ide - 2 .GT. ite) THEN
 655       i_end = ite
 656     ELSE
 657       i_end = ide - 2
 658     END IF
 659   END IF
 660   IF (config_flags%specified .OR. config_flags%nested) THEN
 661     IF (jds + 1 .LT. jts) THEN
 662       j_start = jts
 663     ELSE
 664       j_start = jds + 1
 665     END IF
 666   END IF
 667   IF (config_flags%specified .OR. config_flags%nested) THEN
 668     IF (jde - 2 .GT. jte) THEN
 669       j_end = jte
 670     ELSE
 671       j_end = jde - 2
 672     END IF
 673   END IF
 674   IF (config_flags%periodic_x) i_start = its
 675   IF (config_flags%periodic_x) THEN
 676     IF (ite .GT. ide - 1) THEN
 677       i_end = ide - 1
 678     ELSE
 679       i_end = ite
 680     END IF
 681   END IF
 682   DO j=j_end,j_start,-1
 683     DO k=ktf,kts,-1
 684       DO i=i_end,i_start,-1
 685         rvarb(i, k, j) = rvarb(i, k, j) + lvarb(i, k, j)
 686       END DO
 687     END DO
 688   END DO
 689 END SUBROUTINE A_ADD_A2A
 690
 691 !        Generated by TAPENADE     (INRIA, Tropics team)
 692 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
 693 !
 694 !  Differentiation of add_a2c_u in reverse (adjoint) mode:
 695 !   gradient     of useful results: lvar rvar
 696 !   with respect to varying inputs: lvar rvar
 697 !   RW status of diff variables: lvar:in-out rvar:incr
 698 SUBROUTINE A_ADD_A2C_U(lvar, lvarb, rvar, rvarb, config_flags, ids, ide&
 699 &  , jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte&
 700 &  , kts, kte)
 701   IMPLICIT NONE
 702 !------------------------------------------------------------
 703   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
 704   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
 705 &  jme, kms, kme, its, ite, jts, jte, kts, kte
 706   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rvar
 707   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rvarb
 708   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: lvar
 709   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: lvarb
 710 ! LOCAL VARS
 711   INTEGER :: i, j, k, i_start, i_end, j_start, j_end, ktf
 712   INTRINSIC MAX
 713   INTRINSIC MIN
 714   IF (kte .GT. kde - 1) THEN
 715     ktf = kde - 1
 716   ELSE
 717     ktf = kte
 718   END IF
 719   i_start = its
 720   i_end = ite
 721   j_start = jts
 722   IF (jte .GT. jde - 1) THEN
 723     j_end = jde - 1
 724   ELSE
 725     j_end = jte
 726   END IF
 727   IF (config_flags%specified .OR. config_flags%nested) THEN
 728     IF (ids + 1 .LT. its) THEN
 729       i_start = its
 730     ELSE
 731       i_start = ids + 1
 732     END IF
 733   END IF
 734   IF (config_flags%specified .OR. config_flags%nested) THEN
 735     IF (ide - 1 .GT. ite) THEN
 736       i_end = ite
 737     ELSE
 738       i_end = ide - 1
 739     END IF
 740   END IF
 741   IF (config_flags%specified .OR. config_flags%nested) THEN
 742     IF (jds + 1 .LT. jts) THEN
 743       j_start = jts
 744     ELSE
 745       j_start = jds + 1
 746     END IF
 747   END IF
 748   IF (config_flags%specified .OR. config_flags%nested) THEN
 749     IF (jde - 2 .GT. jte) THEN
 750       j_end = jte
 751     ELSE
 752       j_end = jde - 2
 753     END IF
 754   END IF
 755   IF (config_flags%periodic_x) i_start = its
 756   IF (config_flags%periodic_x) i_end = ite
 757   DO j=j_end,j_start,-1
 758     DO k=ktf,kts,-1
 759       DO i=i_end,i_start,-1
 760         rvarb(i, k, j) = rvarb(i, k, j) + 0.5*lvarb(i, k, j)
 761         rvarb(i-1, k, j) = rvarb(i-1, k, j) + 0.5*lvarb(i, k, j)
 762       END DO
 763     END DO
 764   END DO
 765 END SUBROUTINE A_ADD_A2C_U
 766
 767 !        Generated by TAPENADE     (INRIA, Tropics team)
 768 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
 769 !
 770 !  Differentiation of add_a2c_v in reverse (adjoint) mode:
 771 !   gradient     of useful results: lvar rvar
 772 !   with respect to varying inputs: lvar rvar
 773 !   RW status of diff variables: lvar:in-out rvar:incr
 774 SUBROUTINE A_ADD_A2C_V(lvar, lvarb, rvar, rvarb, config_flags, ids, ide&
 775 &  , jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte&
 776 &  , kts, kte)
 777   IMPLICIT NONE
 778 !------------------------------------------------------------
 779   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
 780   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
 781 &  jme, kms, kme, its, ite, jts, jte, kts, kte
 782   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rvar
 783   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rvarb
 784   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: lvar
 785   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: lvarb
 786 ! LOCAL VARS
 787   INTEGER :: i, j, k, i_start, i_end, j_start, j_end, ktf
 788   INTRINSIC MAX
 789   INTRINSIC MIN
 790   i_start = its
 791   IF (ite .GT. ide - 1) THEN
 792     i_end = ide - 1
 793   ELSE
 794     i_end = ite
 795   END IF
 796   j_start = jts
 797   j_end = jte
 798   IF (config_flags%specified .OR. config_flags%nested) THEN
 799     IF (ids + 1 .LT. its) THEN
 800       i_start = its
 801     ELSE
 802       i_start = ids + 1
 803     END IF
 804   END IF
 805   IF (config_flags%specified .OR. config_flags%nested) THEN
 806     IF (ide - 2 .GT. ite) THEN
 807       i_end = ite
 808     ELSE
 809       i_end = ide - 2
 810     END IF
 811   END IF
 812   IF (config_flags%specified .OR. config_flags%nested) THEN
 813     IF (jds + 1 .LT. jts) THEN
 814       j_start = jts
 815     ELSE
 816       j_start = jds + 1
 817     END IF
 818   END IF
 819   IF (config_flags%specified .OR. config_flags%nested) THEN
 820     IF (jde - 1 .GT. jte) THEN
 821       j_end = jte
 822     ELSE
 823       j_end = jde - 1
 824     END IF
 825   END IF
 826   IF (config_flags%periodic_x) i_start = its
 827   IF (config_flags%periodic_x) THEN
 828     IF (ite .GT. ide - 1) THEN
 829       i_end = ide - 1
 830     ELSE
 831       i_end = ite
 832     END IF
 833   END IF
 834   DO j=j_end,j_start,-1
 835     DO k=kte,kts,-1
 836       DO i=i_end,i_start,-1
 837         rvarb(i, k, j) = rvarb(i, k, j) + 0.5*lvarb(i, k, j)
 838         rvarb(i, k, j-1) = rvarb(i, k, j-1) + 0.5*lvarb(i, k, j)
 839       END DO
 840     END DO
 841   END DO
 842 END SUBROUTINE A_ADD_A2C_V
 843
 844 #endif
 845
 846 END MODULE a_module_physics_addtendc