/[lmdze]/trunk/dyn3d/Guide/guide.f
ViewVC logotype

Diff of /trunk/dyn3d/Guide/guide.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 29 by guez, Tue Mar 30 10:44:42 2010 UTC revision 37 by guez, Tue Dec 21 15:45:48 2010 UTC
# Line 3  MODULE guide_m Line 3  MODULE guide_m
3    ! From dyn3d/guide.F, version 1.3 2005/05/25 13:10:09    ! From dyn3d/guide.F, version 1.3 2005/05/25 13:10:09
4    ! and dyn3d/guide.h, version 1.1.1.1 2004/05/19 12:53:06    ! and dyn3d/guide.h, version 1.1.1.1 2004/05/19 12:53:06
5    
6    REAL :: tau_min_u, tau_max_u    IMPLICIT NONE
   REAL :: tau_min_v, tau_max_v  
   REAL :: tau_min_t, tau_max_t  
   REAL :: tau_min_q, tau_max_q  
   REAL :: tau_min_p, tau_max_p  
   REAL :: aire_min, aire_max  
7    
8      REAL tau_min_u, tau_max_u
9      REAL tau_min_v, tau_max_v
10      REAL tau_min_t, tau_max_t
11      REAL tau_min_q, tau_max_q
12      REAL tau_min_p, tau_max_p
13      REAL aire_min, aire_max
14    
   LOGICAL :: guide_u, guide_v, guide_t, guide_q, guide_p  
   REAL :: lat_min_guide, lat_max_guide  
15    
16    LOGICAL :: ncep, ini_anal    LOGICAL guide_u, guide_v, guide_t, guide_q, guide_p
17    INTEGER :: online    LOGICAL ncep, ini_anal
18      INTEGER online
19    
20  CONTAINS  CONTAINS
21    
# Line 32  CONTAINS Line 32  CONTAINS
32      USE serre, ONLY : clat, clon      USE serre, ONLY : clat, clon
33      USE q_sat_m, ONLY : q_sat      USE q_sat_m, ONLY : q_sat
34      USE exner_hyb_m, ONLY : exner_hyb      USE exner_hyb_m, ONLY : exner_hyb
     USE pression_m, ONLY : pression  
35      USE inigrads_m, ONLY : inigrads      USE inigrads_m, ONLY : inigrads
36      use netcdf, only: nf90_nowrite, nf90_open, nf90_close      use netcdf, only: nf90_nowrite, nf90_open, nf90_close
37        use tau2alpha_m, only: tau2alpha
     IMPLICIT NONE  
38    
39      INCLUDE 'netcdf.inc'      INCLUDE 'netcdf.inc'
40    
41      !   variables dynamiques      !   variables dynamiques
42      REAL :: vcov(ip1jm, llm), ucov(ip1jmp1, llm) ! vents covariants      REAL vcov(ip1jm, llm), ucov(ip1jmp1, llm) ! vents covariants
43      REAL, intent(inout):: teta(ip1jmp1, llm) ! temperature potentielle      REAL, intent(inout):: teta(ip1jmp1, llm) ! temperature potentielle
44      REAL :: q(ip1jmp1, llm) ! temperature potentielle      REAL q(ip1jmp1, llm) ! temperature potentielle
45      REAL :: ps(ip1jmp1) ! pression  au sol      REAL ps(ip1jmp1) ! pression  au sol
46      REAL :: masse(ip1jmp1, llm) ! masse d'air      REAL masse(ip1jmp1, llm) ! masse d'air
47    
48      !   common passe pour des sorties      !   common passe pour des sorties
49      REAL :: dxdys(iip1, jjp1), dxdyu(iip1, jjp1), dxdyv(iip1, jjm)      REAL dxdys(iip1, jjp1), dxdyu(iip1, jjp1), dxdyv(iip1, jjm)
50      COMMON /comdxdy/dxdys, dxdyu, dxdyv      COMMON /comdxdy/dxdys, dxdyu, dxdyv
51    
52      !   variables dynamiques pour les reanalyses.      !   variables dynamiques pour les reanalyses.
53      REAL :: ucovrea1(ip1jmp1, llm), vcovrea1(ip1jm, llm) !vts cov reas      REAL ucovrea1(ip1jmp1, llm), vcovrea1(ip1jm, llm) !vts cov reas
54      REAL :: tetarea1(ip1jmp1, llm) ! temp pot  reales      REAL tetarea1(ip1jmp1, llm) ! temp pot  reales
55      REAL :: qrea1(ip1jmp1, llm) ! temp pot  reales      REAL qrea1(ip1jmp1, llm) ! temp pot  reales
56      REAL :: psrea1(ip1jmp1) ! ps      REAL psrea1(ip1jmp1) ! ps
57      REAL :: ucovrea2(ip1jmp1, llm), vcovrea2(ip1jm, llm) !vts cov reas      REAL ucovrea2(ip1jmp1, llm), vcovrea2(ip1jm, llm) !vts cov reas
58      REAL :: tetarea2(ip1jmp1, llm) ! temp pot  reales      REAL tetarea2(ip1jmp1, llm) ! temp pot  reales
59      REAL :: qrea2(ip1jmp1, llm) ! temp pot  reales      REAL qrea2(ip1jmp1, llm) ! temp pot  reales
60      REAL :: masserea2(ip1jmp1, llm) ! masse      REAL masserea2(ip1jmp1, llm) ! masse
61      REAL :: psrea2(ip1jmp1) ! ps      REAL psrea2(ip1jmp1) ! ps
62    
63      REAL :: alpha_q(ip1jmp1)      REAL alpha_q(ip1jmp1)
64      REAL :: alpha_t(ip1jmp1), alpha_p(ip1jmp1)      REAL alpha_t(ip1jmp1), alpha_p(ip1jmp1)
65      REAL :: alpha_u(ip1jmp1), alpha_v(ip1jm)      REAL alpha_u(ip1jmp1), alpha_v(ip1jm)
66      REAL :: dday_step, toto, reste, itau_test      REAL dday_step, toto, reste, itau_test
67      INTEGER :: step_rea, count_no_rea      INTEGER step_rea, count_no_rea
68    
69      INTEGER :: ilon, ilat      INTEGER ilon, ilat
70      REAL :: factt, ztau(ip1jmp1)      REAL factt, ztau(ip1jmp1)
71    
72      INTEGER, INTENT (IN) :: itau      INTEGER, INTENT (IN) :: itau
73      INTEGER :: ij, l      INTEGER ij, l
74      INTEGER :: ncidpl, varidpl, nlev, status      INTEGER ncidpl, varidpl, nlev, status
75      INTEGER :: rcod, rid      INTEGER rcod, rid
76      REAL :: ditau, tau, a      REAL ditau, tau, a
77      SAVE nlev      SAVE nlev
78    
79      !  TEST SUR QSAT      !  TEST SUR QSAT
80      REAL :: p(ip1jmp1, llmp1), pk(ip1jmp1, llm), pks(ip1jmp1)      REAL p(ip1jmp1, llmp1), pk(ip1jmp1, llm), pks(ip1jmp1)
81      REAL :: pkf(ip1jmp1, llm)      REAL pkf(ip1jmp1, llm)
82      REAL :: pres(ip1jmp1, llm)      REAL pres(ip1jmp1, llm)
83    
84      REAL :: qsat(ip1jmp1, llm)      REAL qsat(ip1jmp1, llm)
85      REAL :: unskap      REAL unskap
86      REAL :: tnat(ip1jmp1, llm)      REAL tnat(ip1jmp1, llm)
   
87    
88      LOGICAL :: first      LOGICAL:: first = .TRUE.
     SAVE first  
     DATA first/ .TRUE./  
89    
90      SAVE ucovrea1, vcovrea1, tetarea1, psrea1, qrea1      SAVE ucovrea1, vcovrea1, tetarea1, psrea1, qrea1
91      SAVE ucovrea2, vcovrea2, tetarea2, masserea2, psrea2, qrea2      SAVE ucovrea2, vcovrea2, tetarea2, masserea2, psrea2, qrea2
# Line 98  CONTAINS Line 93  CONTAINS
93      SAVE alpha_t, alpha_q, alpha_u, alpha_v, alpha_p, itau_test      SAVE alpha_t, alpha_q, alpha_u, alpha_v, alpha_p, itau_test
94      SAVE step_rea, count_no_rea      SAVE step_rea, count_no_rea
95    
96      CHARACTER (10) :: file      CHARACTER (10) file
97      INTEGER :: igrads      INTEGER igrads
98      REAL :: dtgrads      REAL dtgrads
99      SAVE igrads, dtgrads      SAVE igrads, dtgrads
100      DATA igrads, dtgrads/2, 100./      DATA igrads, dtgrads/2, 100./
101    
# Line 110  CONTAINS Line 105  CONTAINS
105    
106      ! calcul de l'humidite saturante      ! calcul de l'humidite saturante
107    
108      CALL pression(ip1jmp1, ap, bp, ps, p)      forall (l = 1: llm + 1) p(:, l) = ap(l) + bp(l) * ps
109      CALL massdair(p, masse)      CALL massdair(p, masse)
110      PRINT *, 'OK1'      PRINT *, 'OK1'
111      CALL exner_hyb(ps, p, pks, pk, pkf)      CALL exner_hyb(ps, p, pks, pk, pkf)
# Line 310  CONTAINS Line 305  CONTAINS
305            ps(ij) = (1.-alpha_p(ij))*ps(ij) + alpha_p(ij)*a            ps(ij) = (1.-alpha_p(ij))*ps(ij) + alpha_p(ij)*a
306            IF (first .AND. ini_anal) ps(ij) = a            IF (first .AND. ini_anal) ps(ij) = a
307         END DO         END DO
308         CALL pression(ip1jmp1, ap, bp, ps, p)         forall (l = 1: llm + 1) p(:, l) = ap(l) + bp(l) * ps
309         CALL massdair(p, masse)         CALL massdair(p, masse)
310      END IF      END IF
311    
# Line 344  CONTAINS Line 339  CONTAINS
339    
340    END SUBROUTINE guide    END SUBROUTINE guide
341    
   !=======================================================================  
   SUBROUTINE tau2alpha(type, pim, pjm, factt, taumin, taumax, alpha)  
     !=======================================================================  
   
     USE dimens_m, ONLY : iim, jjm  
     USE paramet_m, ONLY : iip1, jjp1  
     USE comconst, ONLY : pi  
     USE comgeom, ONLY : cu_2d, cv_2d, rlatu, rlatv  
     USE serre, ONLY : clat, clon, grossismx, grossismy  
     IMPLICIT NONE  
   
     !   arguments :  
     INTEGER :: type  
     INTEGER :: pim, pjm  
     REAL :: factt, taumin, taumax  
     REAL :: dxdy_, alpha(pim, pjm)  
     REAL :: dxdy_min, dxdy_max  
   
     !  local :  
     REAL :: alphamin, alphamax, gamma, xi  
     SAVE gamma  
     INTEGER :: i, j, ilon, ilat  
   
     LOGICAL :: first  
     SAVE first  
     DATA first/ .TRUE./  
   
     REAL :: zdx(iip1, jjp1), zdy(iip1, jjp1)  
   
     REAL :: zlat  
     REAL :: dxdys(iip1, jjp1), dxdyu(iip1, jjp1), dxdyv(iip1, jjm)  
     COMMON /comdxdy/dxdys, dxdyu, dxdyv  
   
     IF (first) THEN  
        DO j = 2, jjm  
           DO i = 2, iip1  
              zdx(i, j) = 0.5*(cu_2d(i-1, j)+cu_2d(i, j))/cos(rlatu(j))  
           END DO  
           zdx(1, j) = zdx(iip1, j)  
        END DO  
        DO j = 2, jjm  
           DO i = 1, iip1  
              zdy(i, j) = 0.5*(cv_2d(i, j-1)+cv_2d(i, j))  
           END DO  
        END DO  
        DO i = 1, iip1  
           zdx(i, 1) = zdx(i, 2)  
           zdx(i, jjp1) = zdx(i, jjm)  
           zdy(i, 1) = zdy(i, 2)  
           zdy(i, jjp1) = zdy(i, jjm)  
        END DO  
        DO j = 1, jjp1  
           DO i = 1, iip1  
              dxdys(i, j) = sqrt(zdx(i, j)*zdx(i, j)+zdy(i, j)*zdy(i, j))  
           END DO  
        END DO  
        DO j = 1, jjp1  
           DO i = 1, iim  
              dxdyu(i, j) = 0.5*(dxdys(i, j)+dxdys(i+1, j))  
           END DO  
           dxdyu(iip1, j) = dxdyu(1, j)  
        END DO  
        DO j = 1, jjm  
           DO i = 1, iip1  
              dxdyv(i, j) = 0.5*(dxdys(i, j)+dxdys(i+1, j))  
           END DO  
        END DO  
   
        CALL dump2d(iip1, jjp1, dxdys, 'DX2DY2 SCAL  ')  
        CALL dump2d(iip1, jjp1, dxdyu, 'DX2DY2 U     ')  
        CALL dump2d(iip1, jjp1, dxdyv, 'DX2DY2 v     ')  
   
        !   coordonnees du centre du zoom  
        CALL coordij(clon, clat, ilon, ilat)  
        !   aire de la maille au centre du zoom  
        dxdy_min = dxdys(ilon, ilat)  
        !   dxdy maximale de la maille  
        dxdy_max = 0.  
        DO j = 1, jjp1  
           DO i = 1, iip1  
              dxdy_max = max(dxdy_max, dxdys(i, j))  
           END DO  
        END DO  
   
        IF (abs(grossismx-1.)<0.1 .OR. abs(grossismy-1.)<0.1) THEN  
           PRINT *, 'ATTENTION modele peu zoome'  
           PRINT *, 'ATTENTION on prend une constante de guidage cste'  
           gamma = 0.  
        ELSE  
           gamma = (dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)  
           PRINT *, 'gamma=', gamma  
           IF (gamma<1.E-5) THEN  
              PRINT *, 'gamma =', gamma, '<1e-5'  
              STOP  
           END IF  
           PRINT *, 'gamma=', gamma  
           gamma = log(0.5)/log(gamma)  
        END IF  
     END IF  
   
     alphamin = factt/taumax  
     alphamax = factt/taumin  
   
     DO j = 1, pjm  
        DO i = 1, pim  
           IF (type==1) THEN  
              dxdy_ = dxdys(i, j)  
              zlat = rlatu(j)*180./pi  
           ELSE IF (type==2) THEN  
              dxdy_ = dxdyu(i, j)  
              zlat = rlatu(j)*180./pi  
           ELSE IF (type==3) THEN  
              dxdy_ = dxdyv(i, j)  
              zlat = rlatv(j)*180./pi  
           END IF  
           IF (abs(grossismx-1.)<0.1 .OR. abs(grossismy-1.)<0.1) THEN  
              !  pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin  
              alpha(i, j) = alphamin  
           ELSE  
              xi = ((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma  
              xi = min(xi, 1.)  
              IF (lat_min_guide<=zlat .AND. zlat<=lat_max_guide) THEN  
                 alpha(i, j) = xi*alphamin + (1.-xi)*alphamax  
              ELSE  
                 alpha(i, j) = 0.  
              END IF  
           END IF  
        END DO  
     END DO  
   
   
     RETURN  
   END SUBROUTINE tau2alpha  
   
342  END MODULE guide_m  END MODULE guide_m
Legend:
Removed from v.29  
changed lines
  Added in v.37
  ViewVC Help
Powered by ViewVC 1.1.21