source: codes/icosagcm/devel/src/dynamics/compute_theta.F90 @ 1027

MODULE compute_theta_mod
  USE prec, ONLY : rstd
  USE grid_param
  USE disvert_mod, ONLY : mass_dak, mass_dbk, caldyn_eta, eta_mass, ptop
  IMPLICIT NONE
  PRIVATE

#include "../unstructured/unstructured.h90"

  PUBLIC :: compute_theta_unst, compute_theta_hex, compute_theta_manual

CONTAINS

  ! Python/Fortran differences to be resolved at some point :

  ! the Fortran driver prognoses ps/mass_col or rhodz depending on caldyn_eta
  ! the Python driver prognoses rhodz even if caldyn_eta==eta_mass
  ! so that the DOFs are the same whatever caldyn_eta

  ! in the Fortran driver dak, dbk are 1D and based on pressure
  ! => m = mass_dak(l)+(mass_col(ij)*g+ptop)*mass_dbk(l)
  !    rhodz(CELL) = m/g 
  ! in the Python driver dak, dbk are 2D and based on mass
  ! => rhodz(CELL) = MASS_DAK(CELL) + mass_col(HIDX(CELL))*MASS_DBK(CELL)

#ifdef BEGIN_DYSL

KERNEL(theta)
  IF(caldyn_eta==eta_mass) THEN ! Compute mass
    ! compute mass_col from rhodz
    SEQUENCE_C1
      PROLOGUE(0)
        mass_col(HIDX(CELL))=0.
      END_BLOCK
      BODY('1,llm')
          mass_col(HIDX(CELL)) = mass_col(HIDX(CELL)) + rhodz(CELL)
      END_BLOCK
    END_BLOCK
    FORALL_CELLS_EXT()
      ON_PRIMAL
        rhodz(CELL) = MASS_DAK(CELL) + mass_col(HIDX(CELL))*MASS_DBK(CELL)
      END_BLOCK
    END_BLOCK
  END IF
  DO iq=1,nqdyn
    FORALL_CELLS_EXT()
      ON_PRIMAL
        theta(CELL,iq) = theta_rhodz(CELL,iq)/rhodz(CELL)
      END_BLOCK
    END_BLOCK
  END DO
END_BLOCK

KERNEL(compute_theta)
  IF(caldyn_eta==eta_mass) THEN ! Compute mass
     FORALL_CELLS_EXT()
       ON_PRIMAL
         m = MASS_DAK(CELL)+(mass_col(HIDX(CELL))*g+ptop)*MASS_DBK(CELL)
         rhodz(CELL) = m/g
        END_BLOCK
     END_BLOCK
  END IF  
  DO iq=1,nqdyn
     FORALL_CELLS_EXT()
       ON_PRIMAL
         theta(CELL,iq) = theta_rhodz(CELL,iq)/rhodz(CELL)
       END_BLOCK
     END_BLOCK
  END DO
END_BLOCK

#endif END_DYSL

!-------------- Wrappers for F2008 conformity -----------------

  SUBROUTINE compute_theta_unst(ps,theta_rhodz, rhodz,theta)
    REAL(rstd),INTENT(IN)    :: ps(:), theta_rhodz(:,:,:)
    REAL(rstd),INTENT(INOUT) :: rhodz(:,:)
    REAL(rstd),INTENT(OUT)   :: theta(:,:,:)
    CALL compute_theta_unst_(ps,theta_rhodz, rhodz,theta)
  END SUBROUTINE compute_theta_unst

  SUBROUTINE compute_theta_hex(ps,theta_rhodz, rhodz,theta)
    REAL(rstd),INTENT(IN)    :: ps(:), theta_rhodz(:,:,:)
    REAL(rstd),INTENT(INOUT) :: rhodz(:,:)
    REAL(rstd),INTENT(OUT)   :: theta(:,:,:)
    CALL compute_theta_hex_(ps,theta_rhodz, rhodz,theta)
  END SUBROUTINE compute_theta_hex

!--------------------------------------------------------------

  SUBROUTINE compute_theta_unst_(mass_col,theta_rhodz, rhodz,theta)
    USE ISO_C_BINDING, only : C_DOUBLE, C_FLOAT
    USE data_unstructured_mod, ONLY : enter_trace, exit_trace, id_theta
    FIELD_PS :: mass_col
    FIELD_MASS :: rhodz
    FIELD_THETA :: theta, theta_rhodz
    DECLARE_INDICES
    NUM :: m
    START_TRACE(id_theta, 3,0,0) ! primal, dual, edge  
#define MASS_DAK(l,ij) mass_dak(l)
#define MASS_DBK(l,ij) mass_dbk(l)
#include "../kernels_unst/theta.k90"
#undef MASS_DAK
#undef MASS_DBK
    STOP_TRACE
  END SUBROUTINE compute_theta_unst_

  SUBROUTINE compute_theta_hex_(mass_col,theta_rhodz, rhodz,theta)
    USE icosa
    USE trace, ONLY : trace_start, trace_end
    USE omp_para, ONLY : ll_begin, ll_end
    REAL(rstd),INTENT(IN)    :: mass_col(iim*jjm)
    REAL(rstd),INTENT(IN)    :: theta_rhodz(iim*jjm,llm,nqdyn)
    REAL(rstd),INTENT(INOUT) :: rhodz(iim*jjm,llm)
    REAL(rstd),INTENT(OUT)   :: theta(iim*jjm,llm,nqdyn)
    INTEGER :: ij,l,iq
    REAL(rstd) :: m
    CALL trace_start("compute_theta")
#define MASS_DAK(ij,l) mass_dak(l)
#define MASS_DBK(ij,l) mass_dbk(l)
#include "../kernels_hex/compute_theta.k90"
#undef MASS_DAK
#undef MASS_DBK
    CALL trace_end("compute_theta")
  END SUBROUTINE compute_theta_hex_
  
  SUBROUTINE compute_theta_manual(ps,theta_rhodz, rhodz,theta)
    USE icosa
    USE trace, ONLY : trace_start, trace_end
    USE omp_para, ONLY : ll_begin, ll_end
    REAL(rstd),INTENT(IN)    :: ps(iim*jjm)
    REAL(rstd),INTENT(IN)    :: theta_rhodz(iim*jjm,llm,nqdyn)
    REAL(rstd),INTENT(INOUT) :: rhodz(iim*jjm,llm)
    REAL(rstd),INTENT(OUT)   :: theta(iim*jjm,llm,nqdyn)
    INTEGER :: ij,l,iq
    REAL(rstd) :: m
    CALL trace_start("compute_theta")

    IF(caldyn_eta==eta_mass) THEN ! Compute mass
       DO l = ll_begin,ll_end
          !DIR$ SIMD
          DO ij=ij_begin_ext,ij_end_ext
             m = mass_dak(l)+(ps(ij)*g+ptop)*mass_dbk(l) ! ps is actually Ms
             rhodz(ij,l) = m/g
          END DO
       END DO
    END IF

    DO l = ll_begin,ll_end
       DO iq=1,nqdyn
          !DIR$ SIMD
          DO ij=ij_begin_ext,ij_end_ext
             theta(ij,l,iq) = theta_rhodz(ij,l,iq)/rhodz(ij,l)
          END DO
       END DO
    END DO

    CALL trace_end("compute_theta")
  END SUBROUTINE compute_theta_manual
  
END MODULE compute_theta_mod