source: codes/icosagcm/trunk/src/etat0_dcmip2.f90 @ 78

MODULE etat0_dcmip2_mod

! test cases DCMIP 2012, category 2 : Orographic gravity waves

  USE genmod

  PRIVATE

  PUBLIC  etat0

CONTAINS


  SUBROUTINE etat0(f_ps,f_phis,f_theta_rhodz,f_u, f_q)
  USE icosa
  IMPLICIT NONE
    TYPE(t_field),POINTER :: f_ps(:)
    TYPE(t_field),POINTER :: f_phis(:)
    TYPE(t_field),POINTER :: f_theta_rhodz(:)
    TYPE(t_field),POINTER :: f_u(:)
    TYPE(t_field),POINTER :: f_q(:)
    
    REAL(rstd),POINTER :: ps(:)
    REAL(rstd),POINTER :: phis(:)
    REAL(rstd),POINTER :: u(:,:)
    REAL(rstd),POINTER :: theta_rhodz(:,:)
    REAL(rstd),POINTER :: q(:,:,:)

    INTEGER :: ind, icase
    CHARACTER(len=255) :: etat0_type
    etat0_type='jablonowsky06'
    CALL getin("etat0",etat0_type)

    SELECT CASE (TRIM(etat0_type))
    CASE('dcmip2_mountain')
       icase=0
    CASE('dcmip2_schaer_noshear')
       icase=1
    CASE('dcmip2_schaer_shear')
       icase=2
    CASE DEFAULT
       PRINT *, 'This should not happen : etat0_type =', TRIM(etat0_type), ' in etat0_dcmip2.f90/etat0'
       STOP
    END SELECT
    PRINT *, 'Orographic gravity-wave test case :', TRIM(etat0_type)

    DO ind=1,ndomain
      CALL swap_dimensions(ind)
      CALL swap_geometry(ind)

      ps=f_ps(ind)
      phis=f_phis(ind)
      u=f_u(ind)
      theta_rhodz=f_theta_rhodz(ind)
      q=f_q(ind)
      CALL compute_etat0_DCMIP2(icase,ps,phis,u,theta_rhodz,q)
    ENDDO
            
  END SUBROUTINE etat0
  
  SUBROUTINE compute_etat0_DCMIP2(icase, ps, phis, u, theta_rhodz,q)
    USE icosa
    USE disvert_ncar_mod, ONLY : ap,bp
    USE pression_mod
    USE theta2theta_rhodz_mod
    USE wind_mod
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: icase
    REAL(rstd), INTENT(OUT) :: ps(iim*jjm)
    REAL(rstd), INTENT(OUT) :: phis(iim*jjm)
    REAL(rstd), INTENT(OUT) :: u(3*iim*jjm,llm)
    REAL(rstd), INTENT(OUT) :: theta_rhodz(iim*jjm,llm)
    REAL(rstd), INTENT(OUT) :: q(iim*jjm)
    REAL(rstd) :: ulon(3*iim*jjm,llm), ulat(3*iim*jjm,llm), temp(iim*jjm,llm)
    
    INTEGER :: i,j,l,ij
    REAL(rstd) :: hyam, hybm, pp, dummy1, dummy2, dummy3  
    
    ! Hexagons : ps,phis,temp
    DO l=1,llm
       ! The surface pressure is not set yet so we provide the hybrid coefficients
       hyam = .5*(ap(l)+ap(l+1))/preff
       hybm = .5*(bp(l)+bp(l+1))
       DO j=jj_begin,jj_end
          DO i=ii_begin,ii_end
             ij=(j-1)*iim+i
             CALL comp_all(xyz_i(ij,:), ps(ij),phis(ij),temp(ij,l), dummy1,dummy2)
          END DO
       END DO
    END DO
    CALL compute_temperature2theta_rhodz(ps,temp,theta_rhodz,1)
    
    ! Edges : ulon,ulat
    DO l=1,llm
       ! The surface pressure is not set yet so we provide the hybrid coefficients
       hyam = .5*(ap(l)+ap(l+1))/preff
       hybm = .5*(bp(l)+bp(l+1))
       DO j=jj_begin,jj_end
          DO i=ii_begin,ii_end
             ij=(j-1)*iim+i
             CALL comp_all(xyz_e(ij+u_right,:), dummy1,dummy2,dummy3, ulon(ij+u_right,l),ulat(ij+u_right,l))
             CALL comp_all(xyz_e(ij+u_lup,:), dummy1,dummy2,dummy3, ulon(ij+u_lup,l),ulat(ij+u_lup,l))
             CALL comp_all(xyz_e(ij+u_ldown,:), dummy1,dummy2,dummy3, ulon(ij+u_ldown,l),ulat(ij+u_ldown,l))
          END DO
       END DO
    END DO
    CALL compute_wind_perp_from_lonlat_compound(ulon,ulat,u)

    CONTAINS
      
      SUBROUTINE comp_all(xyz, psj,phisj,tempj, ulonj,ulatj)
        USE dcmip_initial_conditions_test_1_2_3
        REAL(rstd), INTENT(IN) :: xyz(3)
        REAL(rstd), INTENT(OUT) :: psj,phisj,tempj,ulonj,ulatj
        REAL :: lon,lat, dummy
        dummy=0.
        CALL xyz2lonlat(xyz,lon,lat)
        SELECT CASE (icase)
        CASE(0)
           CALL test2_steady_state_mountain(lon,lat,dummy,dummy,0,.TRUE.,hyam,hybm, &
                ulonj,ulatj,dummy,tempj,phisj,psj,dummy,dummy)
        CASE(1)
           CALL test2_schaer_mountain(lon,lat,dummy,dummy,0,.TRUE.,hyam,hybm,0,&
                ulonj,ulatj,dummy,tempj,phisj,psj,dummy,dummy)
        CASE(2)
           CALL test2_schaer_mountain(lon,lat,dummy,dummy,0,.TRUE.,hyam,hybm,1, &
                ulonj,ulatj,dummy,tempj,phisj,psj,dummy,dummy)
        END SELECT
      END SUBROUTINE comp_all

  END SUBROUTINE compute_etat0_DCMIP2


END MODULE etat0_dcmip2_mod