/[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 83 by guez, Thu Mar 6 15:12:00 2014 UTC revision 107 by guez, Thu Sep 11 15:09:15 2014 UTC
# Line 9  MODULE guide_m Line 9  MODULE guide_m
9    
10  CONTAINS  CONTAINS
11    
12    SUBROUTINE guide(itau, ucov, vcov, teta, q, masse, ps)    SUBROUTINE guide(itau, ucov, vcov, teta, q, ps)
13    
14      ! Author: F.Hourdin      ! Author: F.Hourdin
15    
# Line 17  CONTAINS Line 17  CONTAINS
17      USE comgeom, ONLY: aire, rlatu, rlonv      USE comgeom, ONLY: aire, rlatu, rlonv
18      USE conf_gcm_m, ONLY: day_step, iperiod      USE conf_gcm_m, ONLY: day_step, iperiod
19      use conf_guide_m, only: conf_guide, guide_u, guide_v, guide_t, guide_q, &      use conf_guide_m, only: conf_guide, guide_u, guide_v, guide_t, guide_q, &
20           guide_p, ncep, ini_anal, tau_min_u, tau_max_u, tau_min_v, tau_max_v, &           ncep, ini_anal, tau_min_u, tau_max_u, tau_min_v, tau_max_v, &
21           tau_min_t, tau_max_t, tau_min_q, tau_max_q, tau_min_p, tau_max_p, &           tau_min_t, tau_max_t, tau_min_q, tau_max_q, online
22           online      USE dimens_m, ONLY: iim, jjm, llm
     USE dimens_m, ONLY: jjm, llm  
23      USE disvert_m, ONLY: ap, bp, preff, presnivs      USE disvert_m, ONLY: ap, bp, preff, presnivs
24        use dump2d_m, only: dump2d
25      USE exner_hyb_m, ONLY: exner_hyb      USE exner_hyb_m, ONLY: exner_hyb
26      USE inigrads_m, ONLY: inigrads      USE inigrads_m, ONLY: inigrads
27      use massdair_m, only: massdair      use netcdf, only: nf90_nowrite
28      use netcdf, only: nf90_nowrite, nf90_open, nf90_close, nf90_inq_dimid, &      use netcdf95, only: nf95_close, nf95_inq_dimid, nf95_inquire_dimension, &
29           nf90_inquire_dimension           nf95_open
30      use nr_util, only: pi      use nr_util, only: pi
31      USE paramet_m, ONLY: iip1, ip1jm, ip1jmp1, jjp1, llmp1      USE paramet_m, ONLY: iip1, ip1jmp1, jjp1, llmp1
32      USE q_sat_m, ONLY: q_sat      USE q_sat_m, ONLY: q_sat
33        use read_reanalyse_m, only: read_reanalyse
34      USE serre, ONLY: clat, clon      USE serre, ONLY: clat, clon
35      use tau2alpha_m, only: tau2alpha, dxdys      use tau2alpha_m, only: tau2alpha, dxdys
36    
37      INTEGER, INTENT(IN):: itau      INTEGER, INTENT(IN):: itau
38    
39      ! variables dynamiques      ! variables dynamiques
40      REAL ucov(ip1jmp1, llm), vcov(ip1jm, llm) ! vents covariants  
41      REAL, intent(inout):: teta(ip1jmp1, llm) ! temperature potentielle      REAL, intent(inout):: ucov(:, :, :) ! (iim + 1, jjm + 1, llm) vent covariant
42      REAL q(ip1jmp1, llm) ! temperature potentielle      REAL, intent(inout):: vcov(:, :, :) ! (iim + 1, jjm, llm) ! vent covariant
43      REAL, intent(out):: masse(ip1jmp1, llm) ! masse d'air  
44      REAL, intent(inout):: ps(ip1jmp1) ! pression au sol      REAL, intent(inout):: teta(iim + 1, jjm + 1, llm) ! température potentielle
45        REAL, intent(inout):: q(iim + 1, jjm + 1, llm)
46        REAL, intent(in):: ps(:, :) ! (iim + 1, jjm + 1) pression au sol
47    
48      ! Local:      ! Local:
49    
50      ! variables dynamiques pour les reanalyses.      ! variables dynamiques pour les reanalyses.
51      REAL, save:: ucovrea1(ip1jmp1, llm), vcovrea1(ip1jm, llm) !vts cov reas  
52      REAL, save:: tetarea1(ip1jmp1, llm) ! temp pot reales      REAL, save:: ucovrea1(iim + 1, jjm + 1, llm), vcovrea1(iim + 1, jjm, llm)
53      REAL, save:: qrea1(ip1jmp1, llm) ! temp pot reales      ! vents covariants reanalyses
54      REAL, save:: psrea1(ip1jmp1) ! ps  
55      REAL, save:: ucovrea2(ip1jmp1, llm), vcovrea2(ip1jm, llm) !vts cov reas      REAL, save:: tetarea1(iim + 1, jjm + 1, llm) ! temp pot reales
56      REAL, save:: tetarea2(ip1jmp1, llm) ! temp pot reales      REAL, save:: qrea1(iim + 1, jjm + 1, llm) ! temp pot reales
57      REAL, save:: qrea2(ip1jmp1, llm) ! temp pot reales  
58        REAL, save:: ucovrea2(iim + 1, jjm + 1, llm), vcovrea2(iim + 1, jjm, llm)
59        ! vents covariants reanalyses
60    
61        REAL, save:: tetarea2(iim + 1, jjm + 1, llm) ! temp pot reales
62        REAL, save:: qrea2(iim + 1, jjm + 1, llm) ! temp pot reales
63      REAL, save:: masserea2(ip1jmp1, llm) ! masse      REAL, save:: masserea2(ip1jmp1, llm) ! masse
     REAL, save:: psrea2(ip1jmp1) ! ps  
64    
65      REAL, save:: alpha_q(ip1jmp1)      ! alpha determine la part des injections de donnees a chaque etape
66      REAL, save:: alpha_t(ip1jmp1), alpha_p(ip1jmp1)      ! alpha=1 signifie pas d'injection
67      REAL, save:: alpha_u(ip1jmp1), alpha_v(ip1jm)      ! alpha=0 signifie injection totale
68      REAL dday_step, toto, reste      REAL, save:: alpha_q(iim + 1, jjm + 1)
69      real, save:: itau_test      REAL, save:: alpha_t(iim + 1, jjm + 1)
70        REAL, save:: alpha_u(iim + 1, jjm + 1), alpha_v(iim + 1, jjm)
71    
72      INTEGER, save:: step_rea, count_no_rea      INTEGER, save:: step_rea, count_no_rea
73    
74      INTEGER ilon, ilat      INTEGER ilon, ilat
75      REAL factt, ztau(ip1jmp1)      REAL factt ! pas de temps entre deux appels au guidage, en fraction de jour
76        real ztau(iim + 1, jjm + 1)
77    
78      INTEGER ij, l      INTEGER ij, l
79      INTEGER ncidpl, varidpl, status      INTEGER ncidpl
80      INTEGER rcod, rid      INTEGER rid
81      REAL ditau, tau, a      REAL tau
82      INTEGER, SAVE:: nlev      INTEGER, SAVE:: nlev
83    
84      ! TEST SUR QSAT      ! TEST SUR QSAT
85      REAL p(ip1jmp1, llmp1), pk(ip1jmp1, llm), pks(ip1jmp1)      REAL p(iim + 1, jjm + 1, llmp1)
86      REAL pkf(ip1jmp1, llm)      real pk(iim + 1, jjm + 1, llm), pks(iim + 1, jjm + 1)
87      REAL pres(ip1jmp1, llm)  
88        REAL qsat(iim + 1, jjm + 1, llm)
89      REAL qsat(ip1jmp1, llm)  
90      REAL unskap      INTEGER, parameter:: igrads = 2
     REAL tnat(ip1jmp1, llm)  
   
     LOGICAL:: first = .TRUE.  
     CHARACTER(len=10) file  
     INTEGER:: igrads = 2  
91      REAL:: dtgrads = 100.      REAL:: dtgrads = 100.
92    
93      !-----------------------------------------------------------------------      !-----------------------------------------------------------------------
94    
95      PRINT *, 'Call sequence information: guide'      PRINT *, 'Call sequence information: guide'
96    
97      ! calcul de l'humidite saturante      first_call: IF (itau == 0) THEN
   
     forall (l = 1: llm + 1) p(:, l) = ap(l) + bp(l) * ps  
     CALL massdair(p, masse)  
     CALL exner_hyb(ps, p, pks, pk, pkf)  
     tnat(:, :) = pk(:, :)*teta(:, :)/cpp  
     unskap = 1./kappa  
     pres(:, :) = preff*(pk(:, :)/cpp)**unskap  
     qsat = q_sat(tnat, pres)  
   
     ! initialisations pour la lecture des reanalyses.  
     ! alpha determine la part des injections de donnees a chaque etape  
     ! alpha=1 signifie pas d'injection  
     ! alpha=0 signifie injection totale  
   
     IF (online==-1) THEN  
        RETURN  
     END IF  
   
     IF (first) THEN  
98         CALL conf_guide         CALL conf_guide
99         file = 'guide'         CALL inigrads(igrads, rlonv, 180. / pi, -180., 180., rlatu, -90., &
100         CALL inigrads(igrads, rlonv, 180./pi, -180., 180., rlatu, -90., 90., &              90., 180. / pi, presnivs, 1., dtgrads, 'guide', 'dyn_zon ')
             180./pi, presnivs, 1., dtgrads, file, 'dyn_zon ')  
        PRINT *, '1: en-ligne, 0: hors-ligne (x=x_rea), -1: climat (x=x_gcm)'  
        IF (online==-1) RETURN  
101    
102         IF (online==1) THEN         IF (online) THEN
103            ! Constantes de temps de rappel en jour            ! Constantes de temps de rappel en jour
           ! 0.1 c'est en gros 2h30.  
           ! 1e10 est une constante infinie donc en gros pas de guidage  
104    
105            ! coordonnees du centre du zoom            ! coordonnees du centre du zoom
106            CALL coordij(clon, clat, ilon, ilat)            CALL coordij(clon, clat, ilon, ilat)
107            ! aire de la maille au centre du zoom            ! aire de la maille au centre du zoom
108            aire_min = aire(ilon+(ilat-1)*iip1)            aire_min = aire(ilon+(ilat - 1) * iip1)
109            ! aire maximale de la maille            ! aire maximale de la maille
110            aire_max = 0.            aire_max = 0.
111            DO ij = 1, ip1jmp1            DO ij = 1, ip1jmp1
112               aire_max = max(aire_max, aire(ij))               aire_max = max(aire_max, aire(ij))
113            END DO            END DO
           ! factt = pas de temps en fraction de jour  
           factt = dtvr*iperiod/daysec  
114    
115            CALL tau2alpha(3, iip1, jjm, factt, tau_min_v, tau_max_v, alpha_v)            factt = dtvr * iperiod / daysec
116            CALL tau2alpha(2, iip1, jjp1, factt, tau_min_u, tau_max_u, alpha_u)  
117            CALL tau2alpha(1, iip1, jjp1, factt, tau_min_t, tau_max_t, alpha_t)            CALL tau2alpha(3, factt, tau_min_v, tau_max_v, alpha_v)
118            CALL tau2alpha(1, iip1, jjp1, factt, tau_min_p, tau_max_p, alpha_p)            CALL tau2alpha(2, factt, tau_min_u, tau_max_u, alpha_u)
119            CALL tau2alpha(1, iip1, jjp1, factt, tau_min_q, tau_max_q, alpha_q)            CALL tau2alpha(1, factt, tau_min_t, tau_max_t, alpha_t)
120              CALL tau2alpha(1, factt, tau_min_q, tau_max_q, alpha_q)
121    
122            CALL dump2d(iip1, jjp1, aire, 'AIRE MAILLe ')            CALL dump2d(iip1, jjp1, aire, 'AIRE MAILLe ')
123            CALL dump2d(iip1, jjp1, alpha_u, 'COEFF U ')            CALL dump2d(iip1, jjp1, alpha_u, 'COEFF U ')
124            CALL dump2d(iip1, jjp1, alpha_t, 'COEFF T ')            CALL dump2d(iip1, jjp1, alpha_t, 'COEFF T ')
   
           ! Cas ou on force exactement par les variables analysees  
125         ELSE         ELSE
126              ! Cas où on force exactement par les variables analysées
127            alpha_t = 0.            alpha_t = 0.
128            alpha_u = 0.            alpha_u = 0.
129            alpha_v = 0.            alpha_v = 0.
130            alpha_p = 0.            alpha_q = 0.
           ! physic=.false.  
131         END IF         END IF
132    
        itau_test = 1001  
133         step_rea = 1         step_rea = 1
134         count_no_rea = 0         count_no_rea = 0
135         ncidpl = -99         ncidpl = -99
136    
        ! itau_test montre si l'importation a deja ete faite au rang itau  
137         ! lecture d'un fichier netcdf pour determiner le nombre de niveaux         ! lecture d'un fichier netcdf pour determiner le nombre de niveaux
138         if (guide_u) then         if (guide_u) call nf95_open('u.nc',Nf90_NOWRITe,ncidpl)
139            if (ncidpl.eq.-99) rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)         if (guide_v) call nf95_open('v.nc',nf90_nowrite,ncidpl)
140         endif         if (guide_T) call nf95_open('T.nc',nf90_nowrite,ncidpl)
141           if (guide_Q) call nf95_open('hur.nc',nf90_nowrite, ncidpl)
        if (guide_v) then  
           if (ncidpl.eq.-99) rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)  
        endif  
   
        if (guide_T) then  
           if (ncidpl.eq.-99) rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)  
        endif  
   
        if (guide_Q) then  
           if (ncidpl.eq.-99) rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)  
        endif  
142    
143         IF (ncep) THEN         IF (ncep) THEN
144            status = nf90_inq_dimid(ncidpl, 'LEVEL', rid)            call nf95_inq_dimid(ncidpl, 'LEVEL', rid)
145         ELSE         ELSE
146            status = nf90_inq_dimid(ncidpl, 'PRESSURE', rid)            call nf95_inq_dimid(ncidpl, 'PRESSURE', rid)
147         END IF         END IF
148         status = nf90_inquire_dimension(ncidpl, rid, len=nlev)         call nf95_inquire_dimension(ncidpl, rid, nclen=nlev)
149         PRINT *, 'nlev', nlev         PRINT *, 'nlev', nlev
150         rcod = nf90_close(ncidpl)         call nf95_close(ncidpl)
151         ! Lecture du premier etat des reanalyses.         ! Lecture du premier etat des reanalyses.
152         CALL read_reanalyse(1, ps, ucovrea2, vcovrea2, tetarea2, qrea2, &         CALL read_reanalyse(1, ps, ucovrea2, vcovrea2, tetarea2, qrea2, &
153              masserea2, psrea2, 1, nlev)              masserea2, nlev)
154         qrea2(:, :) = max(qrea2(:, :), 0.1)         qrea2 = max(qrea2, 0.1)
155        END IF first_call
        ! Debut de l'integration temporelle:  
     END IF ! first  
156    
157      ! IMPORTATION DES VENTS, PRESSION ET TEMPERATURE REELS:      ! IMPORTATION DES VENTS, PRESSION ET TEMPERATURE REELS:
158    
159      ditau = real(itau)      ! Nudging fields are given 4 times per day:
160      dday_step = real(day_step)      IF (mod(itau, day_step / 4) == 0) THEN
161      WRITE (*, *) 'ditau, dday_step'         vcovrea1 = vcovrea2
162      WRITE (*, *) ditau, dday_step         ucovrea1 = ucovrea2
163      toto = 4*ditau/dday_step         tetarea1 = tetarea2
164      reste = toto - aint(toto)         qrea1 = qrea2
165    
166      IF (reste==0.) THEN         PRINT *, 'LECTURE REANALYSES, pas ', step_rea, 'apres ', &
167         IF (itau_test==itau) THEN              count_no_rea, ' non lectures'
168            WRITE (*, *) 'deuxieme passage de advreel a itau=', itau         step_rea = step_rea + 1
169            STOP         CALL read_reanalyse(step_rea, ps, ucovrea2, vcovrea2, tetarea2, qrea2, &
170         ELSE              masserea2, nlev)
171            vcovrea1(:, :) = vcovrea2(:, :)         qrea2 = max(qrea2, 0.1)
172            ucovrea1(:, :) = ucovrea2(:, :)         factt = dtvr * iperiod / daysec
173            tetarea1(:, :) = tetarea2(:, :)         ztau = factt / max(alpha_t, 1E-10)
174            qrea1(:, :) = qrea2(:, :)         CALL wrgrads(igrads, 1, aire, 'aire ', 'aire ')
175           CALL wrgrads(igrads, 1, dxdys, 'dxdy ', 'dxdy ')
176            PRINT *, 'LECTURE REANALYSES, pas ', step_rea, 'apres ', &         CALL wrgrads(igrads, 1, alpha_u, 'au ', 'au ')
177                 count_no_rea, ' non lectures'         CALL wrgrads(igrads, 1, alpha_t, 'at ', 'at ')
178            step_rea = step_rea + 1         CALL wrgrads(igrads, 1, ztau, 'taut ', 'taut ')
179            itau_test = itau         CALL wrgrads(igrads, llm, ucov, 'u ', 'u ')
180            CALL read_reanalyse(step_rea, ps, ucovrea2, vcovrea2, tetarea2, &         CALL wrgrads(igrads, llm, ucovrea2, 'ua ', 'ua ')
181                 qrea2, masserea2, psrea2, 1, nlev)         CALL wrgrads(igrads, llm, teta, 'T ', 'T ')
182            qrea2(:, :) = max(qrea2(:, :), 0.1)         CALL wrgrads(igrads, llm, tetarea2, 'Ta ', 'Ta ')
183            factt = dtvr*iperiod/daysec         CALL wrgrads(igrads, llm, qrea2, 'Qa ', 'Qa ')
184            ztau(:) = factt/max(alpha_t(:), 1.E-10)         CALL wrgrads(igrads, llm, q, 'Q ', 'Q ')
           CALL wrgrads(igrads, 1, aire, 'aire ', 'aire ')  
           CALL wrgrads(igrads, 1, dxdys, 'dxdy ', 'dxdy ')  
           CALL wrgrads(igrads, 1, alpha_u, 'au ', 'au ')  
           CALL wrgrads(igrads, 1, alpha_t, 'at ', 'at ')  
           CALL wrgrads(igrads, 1, ztau, 'taut ', 'taut ')  
           CALL wrgrads(igrads, llm, ucov, 'u ', 'u ')  
           CALL wrgrads(igrads, llm, ucovrea2, 'ua ', 'ua ')  
           CALL wrgrads(igrads, llm, teta, 'T ', 'T ')  
           CALL wrgrads(igrads, llm, tetarea2, 'Ta ', 'Ta ')  
           CALL wrgrads(igrads, llm, qrea2, 'Qa ', 'Qa ')  
           CALL wrgrads(igrads, llm, q, 'Q ', 'Q ')  
   
           CALL wrgrads(igrads, llm, qsat, 'QSAT ', 'QSAT ')  
   
        END IF  
185      ELSE      ELSE
186         count_no_rea = count_no_rea + 1         count_no_rea = count_no_rea + 1
187      END IF      END IF
188    
189      ! Guidage      ! Guidage
     ! x_gcm = a * x_gcm + (1-a) * x_reanalyses  
190    
191      IF (ini_anal) PRINT *, 'ATTENTION !!! ON PART DU GUIDAGE'      tau = mod(real(itau) / real(day_step / 4), 1.)
192    
193      ditau = real(itau)      ! x_gcm = a * x_gcm + (1 - a) * x_reanalyses
     dday_step = real(day_step)  
194    
     tau = 4*ditau/dday_step  
     tau = tau - aint(tau)  
   
     ! ucov  
195      IF (guide_u) THEN      IF (guide_u) THEN
196         DO l = 1, llm         IF (itau == 0 .AND. ini_anal) then
197            DO ij = 1, ip1jmp1            ucov = ucovrea1
198               a = (1.-tau)*ucovrea1(ij, l) + tau*ucovrea2(ij, l)         else
199               ucov(ij, l) = (1.-alpha_u(ij))*ucov(ij, l) + alpha_u(ij)*a            forall (l = 1: llm) ucov(:, :, l) = (1. - alpha_u) * ucov(:, :, l) &
200               IF (first .AND. ini_anal) ucov(ij, l) = a                 + alpha_u * ((1. - tau) * ucovrea1(:, :, l) &
201            END DO                 + tau * ucovrea2(:, :, l))
202         END DO         end IF
203      END IF      END IF
204    
205      IF (guide_t) THEN      IF (guide_t) THEN
206         DO l = 1, llm         IF (itau == 0 .AND. ini_anal) then
207            DO ij = 1, ip1jmp1            teta = tetarea1
208               a = (1.-tau)*tetarea1(ij, l) + tau*tetarea2(ij, l)         else
209               teta(ij, l) = (1.-alpha_t(ij))*teta(ij, l) + alpha_t(ij)*a            forall (l = 1: llm) teta(:, :, l) = (1. - alpha_t) * teta(:, :, l) &
210               IF (first .AND. ini_anal) teta(ij, l) = a                 + alpha_t * ((1. - tau) * tetarea1(:, :, l) &
211            END DO                 + tau * tetarea2(:, :, l))
212         END DO         end IF
     END IF  
   
     ! P  
     IF (guide_p) THEN  
        DO ij = 1, ip1jmp1  
           a = (1.-tau)*psrea1(ij) + tau*psrea2(ij)  
           ps(ij) = (1.-alpha_p(ij))*ps(ij) + alpha_p(ij)*a  
           IF (first .AND. ini_anal) ps(ij) = a  
        END DO  
        forall (l = 1: llm + 1) p(:, l) = ap(l) + bp(l) * ps  
        CALL massdair(p, masse)  
213      END IF      END IF
214    
     ! q  
215      IF (guide_q) THEN      IF (guide_q) THEN
216         DO l = 1, llm         ! Calcul de l'humidité saturante :
217            DO ij = 1, ip1jmp1         forall (l = 1: llm + 1) p(:, :, l) = ap(l) + bp(l) * ps
218               a = (1.-tau)*qrea1(ij, l) + tau*qrea2(ij, l)         CALL exner_hyb(ps, p, pks, pk)
219               ! hum relative en % -> hum specif         qsat = q_sat(pk * teta / cpp, preff * (pk / cpp)**(1. / kappa))
220               a = qsat(ij, l)*a*0.01  
221               q(ij, l) = (1.-alpha_q(ij))*q(ij, l) + alpha_q(ij)*a         ! humidité relative en % -> humidité spécifique
222               IF (first .AND. ini_anal) q(ij, l) = a         IF (itau == 0 .AND. ini_anal) then
223            END DO            q = qsat * qrea1 * 0.01
224         END DO         else
225              forall (l = 1: llm) q(:, :, l) = (1. - alpha_q) * q(:, :, l) &
226                   + alpha_q * (qsat(:, :, l) * ((1. - tau) * qrea1(:, :, l) &
227                   + tau * qrea2(:, :, l)) * 0.01)
228           end IF
229      END IF      END IF
230    
     ! vcov  
231      IF (guide_v) THEN      IF (guide_v) THEN
232         DO l = 1, llm         IF (itau == 0 .AND. ini_anal) then
233            DO ij = 1, ip1jm            vcov = vcovrea1
234               a = (1.-tau)*vcovrea1(ij, l) + tau*vcovrea2(ij, l)         else
235               vcov(ij, l) = (1.-alpha_v(ij))*vcov(ij, l) + alpha_v(ij)*a            forall (l = 1: llm) vcov(:, :, l) = (1. - alpha_v) * vcov(:, :, l) &
236               IF (first .AND. ini_anal) vcov(ij, l) = a                 + alpha_v * ((1. - tau) * vcovrea1(:, :, l) &
237            END DO                 + tau * vcovrea2(:, :, l))
238            IF (first .AND. ini_anal) vcov(ij, l) = a         end IF
        END DO  
239      END IF      END IF
240    
     first = .FALSE.  
   
241    END SUBROUTINE guide    END SUBROUTINE guide
242    
243  END MODULE guide_m  END MODULE guide_m
Legend:
Removed from v.83  
changed lines
  Added in v.107
  ViewVC Help
Powered by ViewVC 1.1.21