/[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

trunk/dyn3d/guide.f revision 103 by guez, Fri Aug 29 13:00:05 2014 UTC trunk/dyn3d/Guide/guide.f revision 254 by guez, Mon Feb 5 10:39:38 2018 UTC
# Line 1  Line 1 
1  MODULE guide_m  MODULE guide_m
2    
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    IMPLICIT NONE    IMPLICIT NONE
7    
   REAL aire_min, aire_max  
   
8  CONTAINS  CONTAINS
9    
10    SUBROUTINE guide(itau, ucov, vcov, teta, q, ps)    SUBROUTINE guide(itau, ucov, vcov, teta, q, ps)
11    
12      ! Author: F.Hourdin      ! Author: F. Hourdin
13    
14      USE comconst, ONLY: cpp, daysec, dtvr, kappa      USE comconst, ONLY: cpp, kappa
15      USE comgeom, ONLY: aire, rlatu, rlonv      USE conf_gcm_m, ONLY: day_step
16      USE conf_gcm_m, ONLY: day_step, iperiod      use conf_guide_m, only: guide_u, guide_v, guide_t, guide_q, ini_anal, &
17      use conf_guide_m, only: conf_guide, guide_u, guide_v, guide_t, guide_q, &           alpha_u, alpha_v, alpha_t, alpha_q
          ncep, ini_anal, tau_min_u, tau_max_u, tau_min_v, tau_max_v, &  
          tau_min_t, tau_max_t, tau_min_q, tau_max_q, online  
18      USE dimens_m, ONLY: iim, jjm, llm      USE dimens_m, ONLY: iim, jjm, llm
19      USE disvert_m, ONLY: ap, bp, preff, presnivs      USE disvert_m, ONLY: ap, bp, preff
     use dump2d_m, only: dump2d  
20      USE exner_hyb_m, ONLY: exner_hyb      USE exner_hyb_m, ONLY: exner_hyb
     USE inigrads_m, ONLY: inigrads  
     use netcdf, only: nf90_nowrite, nf90_close, nf90_inq_dimid  
     use netcdf95, only: nf95_inquire_dimension, nf95_open  
     use nr_util, only: pi  
     USE paramet_m, ONLY: iip1, ip1jmp1, jjp1, llmp1  
21      USE q_sat_m, ONLY: q_sat      USE q_sat_m, ONLY: q_sat
22      use read_reanalyse_m, only: read_reanalyse      use read_reanalyse_m, only: read_reanalyse
23      USE serre, ONLY: clat, clon      use writefield_m, only: writefield
     use tau2alpha_m, only: tau2alpha, dxdys  
24    
25      INTEGER, INTENT(IN):: itau      INTEGER, INTENT(IN):: itau
   
     ! variables dynamiques  
   
26      REAL, intent(inout):: ucov(:, :, :) ! (iim + 1, jjm + 1, llm) vent covariant      REAL, intent(inout):: ucov(:, :, :) ! (iim + 1, jjm + 1, llm) vent covariant
27      REAL, intent(inout):: vcov(:, :, :) ! (iim + 1, jjm, llm) ! vent covariant      REAL, intent(inout):: vcov(:, :, :) ! (iim + 1, jjm, llm) ! vent covariant
28    
29      REAL, intent(inout):: teta(iim + 1, jjm + 1, llm) ! température potentielle      REAL, intent(inout):: teta(:, :, :) ! (iim + 1, jjm + 1, llm)
30      REAL, intent(inout):: q(iim + 1, jjm + 1, llm)      ! température potentielle
31    
32        REAL, intent(inout):: q(:, :, :) ! (iim + 1, jjm + 1, llm)
33      REAL, intent(in):: ps(:, :) ! (iim + 1, jjm + 1) pression au sol      REAL, intent(in):: ps(:, :) ! (iim + 1, jjm + 1) pression au sol
34    
35      ! Local:      ! Local:
36    
37      ! variables dynamiques pour les reanalyses.      ! Variables dynamiques pour les réanalyses
38    
39      REAL, save:: ucovrea1(iim + 1, jjm + 1, llm), vcovrea1(iim + 1, jjm, llm)      REAL, save:: ucovrea1(iim + 1, jjm + 1, llm), vcovrea1(iim + 1, jjm, llm)
40      ! vents covariants reanalyses      ! vents covariants r\'eanalyses
41    
42      REAL, save:: tetarea1(iim + 1, jjm + 1, llm) ! temp pot reales      REAL, save:: tetarea1(iim + 1, jjm + 1, llm)
43      REAL, save:: qrea1(iim + 1, jjm + 1, llm) ! temp pot reales      ! potential temperture from reanalysis
44    
45        REAL, save:: qrea1(iim + 1, jjm + 1, llm)
46    
47      REAL, save:: ucovrea2(iim + 1, jjm + 1, llm), vcovrea2(iim + 1, jjm, llm)      REAL, save:: ucovrea2(iim + 1, jjm + 1, llm), vcovrea2(iim + 1, jjm, llm)
48      ! vents covariants reanalyses      ! vents covariants reanalyses
49    
50      REAL, save:: tetarea2(iim + 1, jjm + 1, llm) ! temp pot reales      REAL, save:: tetarea2(iim + 1, jjm + 1, llm)
51      REAL, save:: qrea2(iim + 1, jjm + 1, llm) ! temp pot reales      ! potential temperture from reanalysis
52      REAL, save:: masserea2(ip1jmp1, llm) ! masse  
53        REAL, save:: qrea2(iim + 1, jjm + 1, llm)
54      ! alpha determine la part des injections de donnees a chaque etape  
55      ! alpha=1 signifie pas d'injection      INTEGER l
     ! alpha=0 signifie injection totale  
     REAL, save:: alpha_q(iim + 1, jjm + 1)  
     REAL, save:: alpha_t(iim + 1, jjm + 1)  
     REAL, save:: alpha_u(iim + 1, jjm + 1), alpha_v(iim + 1, jjm)  
   
     INTEGER, save:: step_rea, count_no_rea  
   
     INTEGER ilon, ilat  
     REAL factt ! pas de temps entre deux appels au guidage, en fraction de jour  
     real ztau(iim + 1, jjm + 1)  
   
     INTEGER ij, l  
     INTEGER ncidpl, status  
     INTEGER rcod, rid  
56      REAL tau      REAL tau
     INTEGER, SAVE:: nlev  
57    
58      ! TEST SUR QSAT      ! TEST SUR QSAT
59      REAL p(iim + 1, jjm + 1, llmp1)      REAL p(iim + 1, jjm + 1, llm + 1)
60      real pk(iim + 1, jjm + 1, llm), pks(iim + 1, jjm + 1)      real pk(iim + 1, jjm + 1, llm), pks(iim + 1, jjm + 1)
   
61      REAL qsat(iim + 1, jjm + 1, llm)      REAL qsat(iim + 1, jjm + 1, llm)
62    
     INTEGER, parameter:: igrads = 2  
     REAL:: dtgrads = 100.  
   
63      !-----------------------------------------------------------------------      !-----------------------------------------------------------------------
64    
65      PRINT *, 'Call sequence information: guide'      IF (itau == 0) THEN
66           ! Lecture du premier état des réanalyses :
67      first_call: IF (itau == 0) THEN         CALL read_reanalyse(ps, ucovrea2, vcovrea2, tetarea2, qrea2)
        CALL conf_guide  
        CALL inigrads(igrads, rlonv, 180. / pi, -180., 180., rlatu, -90., &  
             90., 180. / pi, presnivs, 1., dtgrads, 'guide', 'dyn_zon ')  
   
        IF (online) THEN  
           ! Constantes de temps de rappel en jour  
   
           ! coordonnees du centre du zoom  
           CALL coordij(clon, clat, ilon, ilat)  
           ! aire de la maille au centre du zoom  
           aire_min = aire(ilon+(ilat - 1) * iip1)  
           ! aire maximale de la maille  
           aire_max = 0.  
           DO ij = 1, ip1jmp1  
              aire_max = max(aire_max, aire(ij))  
           END DO  
   
           factt = dtvr * iperiod / daysec  
   
           CALL tau2alpha(3, factt, tau_min_v, tau_max_v, alpha_v)  
           CALL tau2alpha(2, factt, tau_min_u, tau_max_u, alpha_u)  
           CALL tau2alpha(1, factt, tau_min_t, tau_max_t, alpha_t)  
           CALL tau2alpha(1, factt, tau_min_q, tau_max_q, alpha_q)  
   
           CALL dump2d(iip1, jjp1, aire, 'AIRE MAILLe ')  
           CALL dump2d(iip1, jjp1, alpha_u, 'COEFF U ')  
           CALL dump2d(iip1, jjp1, alpha_t, 'COEFF T ')  
        ELSE  
           ! Cas ou on force exactement par les variables analysees  
           alpha_t = 0.  
           alpha_u = 0.  
           alpha_v = 0.  
           alpha_q = 0.  
        END IF  
   
        step_rea = 1  
        count_no_rea = 0  
        ncidpl = -99  
   
        ! lecture d'un fichier netcdf pour determiner le nombre de niveaux  
        if (guide_u) call nf95_open('u.nc',Nf90_NOWRITe,ncidpl)  
        if (guide_v) call nf95_open('v.nc',nf90_nowrite,ncidpl)  
        if (guide_T) call nf95_open('T.nc',nf90_nowrite,ncidpl)  
        if (guide_Q) call nf95_open('hur.nc',nf90_nowrite, ncidpl)  
   
        IF (ncep) THEN  
           status = nf90_inq_dimid(ncidpl, 'LEVEL', rid)  
        ELSE  
           status = nf90_inq_dimid(ncidpl, 'PRESSURE', rid)  
        END IF  
        call nf95_inquire_dimension(ncidpl, rid, nclen=nlev)  
        PRINT *, 'nlev', nlev  
        rcod = nf90_close(ncidpl)  
        ! Lecture du premier etat des reanalyses.  
        CALL read_reanalyse(1, ps, ucovrea2, vcovrea2, tetarea2, qrea2, &  
             masserea2, nlev)  
68         qrea2 = max(qrea2, 0.1)         qrea2 = max(qrea2, 0.1)
     END IF first_call  
69    
70      ! IMPORTATION DES VENTS, PRESSION ET TEMPERATURE REELS:         if (ini_anal) then
71              IF (guide_u) ucov = ucovrea2
72              IF (guide_v) vcov = vcovrea2
73              IF (guide_t) teta = tetarea2
74    
75              IF (guide_q) then
76                 ! Calcul de l'humidité saturante :
77                 forall (l = 1: llm + 1) p(:, :, l) = ap(l) + bp(l) * ps
78                 CALL exner_hyb(ps, p, pks, pk)
79                 q = q_sat(pk * teta / cpp, preff * (pk / cpp)**(1. / kappa)) &
80                      * qrea2 * 0.01
81              end IF
82           end if
83        END IF
84    
85        ! Importation des vents, pression et temp\'erature r\'eels :
86    
87      ! Nudging fields are given 4 times per day:      ! Nudging fields are given 4 times per day:
88      IF (mod(itau, day_step / 4) == 0) THEN      IF (mod(itau, day_step / 4) == 0) THEN
# Line 162  CONTAINS Line 91  CONTAINS
91         tetarea1 = tetarea2         tetarea1 = tetarea2
92         qrea1 = qrea2         qrea1 = qrea2
93    
94         PRINT *, 'LECTURE REANALYSES, pas ', step_rea, 'apres ', &         CALL read_reanalyse(ps, ucovrea2, vcovrea2, tetarea2, qrea2)
             count_no_rea, ' non lectures'  
        step_rea = step_rea + 1  
        CALL read_reanalyse(step_rea, ps, ucovrea2, vcovrea2, tetarea2, qrea2, &  
             masserea2, nlev)  
95         qrea2 = max(qrea2, 0.1)         qrea2 = max(qrea2, 0.1)
96         factt = dtvr * iperiod / daysec  
97         ztau = factt / max(alpha_t, 1E-10)         if (guide_u) then
98         CALL wrgrads(igrads, 1, aire, 'aire ', 'aire ')            CALL writefield("ucov", ucov)
99         CALL wrgrads(igrads, 1, dxdys, 'dxdy ', 'dxdy ')            CALL writefield("ucovrea2", ucovrea2)
100         CALL wrgrads(igrads, 1, alpha_u, 'au ', 'au ')         end if
101         CALL wrgrads(igrads, 1, alpha_t, 'at ', 'at ')  
102         CALL wrgrads(igrads, 1, ztau, 'taut ', 'taut ')         if (guide_t) then
103         CALL wrgrads(igrads, llm, ucov, 'u ', 'u ')            CALL writefield("teta", teta)
104         CALL wrgrads(igrads, llm, ucovrea2, 'ua ', 'ua ')            CALL writefield("tetarea2", tetarea2)
105         CALL wrgrads(igrads, llm, teta, 'T ', 'T ')         end if
106         CALL wrgrads(igrads, llm, tetarea2, 'Ta ', 'Ta ')  
107         CALL wrgrads(igrads, llm, qrea2, 'Qa ', 'Qa ')         if (guide_q) then
108         CALL wrgrads(igrads, llm, q, 'Q ', 'Q ')            CALL writefield("qrea2", qrea2)
109      ELSE            CALL writefield("q", q)
110         count_no_rea = count_no_rea + 1         end if
111      END IF      END IF
112    
113      ! Guidage      ! Guidage
# Line 191  CONTAINS Line 116  CONTAINS
116    
117      ! x_gcm = a * x_gcm + (1 - a) * x_reanalyses      ! x_gcm = a * x_gcm + (1 - a) * x_reanalyses
118    
119      IF (guide_u) THEN      IF (guide_u) forall (l = 1: llm) ucov(:, :, l) = (1. - alpha_u) &
120         IF (itau == 0 .AND. ini_anal) then           * ucov(:, :, l) + alpha_u * ((1. - tau) * ucovrea1(:, :, l) + tau &
121            ucov = ucovrea1           * ucovrea2(:, :, l))
122         else  
123            forall (l = 1: llm) ucov(:, :, l) = (1. - alpha_u) * ucov(:, :, l) &      IF (guide_v) forall (l = 1: llm) vcov(:, :, l) = (1. - alpha_v) &
124                 + alpha_u * ((1. - tau) * ucovrea1(:, :, l) &           * vcov(:, :, l) + alpha_v * ((1. - tau) * vcovrea1(:, :, l) + tau &
125                 + tau * ucovrea2(:, :, l))           * vcovrea2(:, :, l))
126         end IF  
127      END IF      IF (guide_t) forall (l = 1: llm) teta(:, :, l) = (1. - alpha_t) &
128             * teta(:, :, l) + alpha_t * ((1. - tau) * tetarea1(:, :, l) + tau &
129      IF (guide_t) THEN           * tetarea2(:, :, l))
        IF (itau == 0 .AND. ini_anal) then  
           teta = tetarea1  
        else  
           forall (l = 1: llm) teta(:, :, l) = (1. - alpha_t) * teta(:, :, l) &  
                + alpha_t * ((1. - tau) * tetarea1(:, :, l) &  
                + tau * tetarea2(:, :, l))  
        end IF  
     END IF  
130    
131      IF (guide_q) THEN      IF (guide_q) THEN
132         ! Calcul de l'humidité saturante :         ! Calcul de l'humidité saturante :
# Line 218  CONTAINS Line 135  CONTAINS
135         qsat = q_sat(pk * teta / cpp, preff * (pk / cpp)**(1. / kappa))         qsat = q_sat(pk * teta / cpp, preff * (pk / cpp)**(1. / kappa))
136    
137         ! humidité relative en % -> humidité spécifique         ! humidité relative en % -> humidité spécifique
138         IF (itau == 0 .AND. ini_anal) then         forall (l = 1: llm) q(:, :, l) = (1. - alpha_q) * q(:, :, l) &
139            q = qsat * qrea1 * 0.01              + alpha_q * (qsat(:, :, l) * ((1. - tau) * qrea1(:, :, l) &
140         else              + tau * qrea2(:, :, l)) * 0.01)
           forall (l = 1: llm) q(:, :, l) = (1. - alpha_q) * q(:, :, l) &  
                + alpha_q * (qsat(:, :, l) * ((1. - tau) * qrea1(:, :, l) &  
                + tau * qrea2(:, :, l)) * 0.01)  
        end IF  
     END IF  
   
     IF (guide_v) THEN  
        IF (itau == 0 .AND. ini_anal) then  
           vcov = vcovrea1  
        else  
           forall (l = 1: llm) vcov(:, :, l) = (1. - alpha_v) * vcov(:, :, l) &  
                + alpha_v * ((1. - tau) * vcovrea1(:, :, l) &  
                + tau * vcovrea2(:, :, l))  
        end IF  
141      END IF      END IF
142    
143    END SUBROUTINE guide    END SUBROUTINE guide
Legend:
Removed from v.103  
changed lines
  Added in v.254
  ViewVC Help
Powered by ViewVC 1.1.21