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

Diff of /trunk/dyn3d/guide.f

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

revision 36 by guez, Thu Dec 2 17:11:04 2010 UTC revision 39 by guez, Tue Jan 25 15:11:05 2011 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      IMPLICIT NONE
7    
8    REAL tau_min_u, tau_max_u    REAL tau_min_u, tau_max_u
9    REAL tau_min_v, tau_max_v    REAL tau_min_v, tau_max_v
10    REAL tau_min_t, tau_max_t    REAL tau_min_t, tau_max_t
# Line 12  MODULE guide_m Line 14  MODULE guide_m
14    
15    
16    LOGICAL guide_u, guide_v, guide_t, guide_q, guide_p    LOGICAL guide_u, guide_v, guide_t, guide_q, guide_p
   REAL lat_min_guide, lat_max_guide  
   
17    LOGICAL ncep, ini_anal    LOGICAL ncep, ini_anal
18    INTEGER online    INTEGER online
19    
# Line 23  CONTAINS Line 23  CONTAINS
23    
24      ! Author: F.Hourdin      ! Author: F.Hourdin
25    
26      USE dimens_m, ONLY : jjm, llm      USE comconst, ONLY : cpp, daysec, dtvr, kappa
     USE paramet_m, ONLY : iip1, ip1jm, ip1jmp1, jjp1, llmp1  
     USE comconst, ONLY : cpp, daysec, dtvr, kappa, pi  
27      USE comvert, ONLY : ap, bp, preff, presnivs      USE comvert, ONLY : ap, bp, preff, presnivs
28      USE conf_gcm_m, ONLY : day_step, iperiod      USE conf_gcm_m, ONLY : day_step, iperiod
29      USE comgeom, ONLY : aire, rlatu, rlonv      USE comgeom, ONLY : aire, rlatu, rlonv
30      USE serre, ONLY : clat, clon      USE dimens_m, ONLY : jjm, llm
     USE q_sat_m, ONLY : q_sat  
31      USE exner_hyb_m, ONLY : exner_hyb      USE exner_hyb_m, ONLY : exner_hyb
     USE pression_m, ONLY : pression  
32      USE inigrads_m, ONLY : inigrads      USE inigrads_m, ONLY : inigrads
33      use netcdf, only: nf90_nowrite, nf90_open, nf90_close      use netcdf, only: nf90_nowrite, nf90_open, nf90_close
34        use nr_util, only: pi
35      IMPLICIT NONE      USE paramet_m, ONLY : iip1, ip1jm, ip1jmp1, jjp1, llmp1
36        USE q_sat_m, ONLY : q_sat
37        USE serre, ONLY : clat, clon
38        use tau2alpha_m, only: tau2alpha
39    
40      INCLUDE 'netcdf.inc'      INCLUDE 'netcdf.inc'
41    
# Line 87  CONTAINS Line 86  CONTAINS
86      REAL unskap      REAL unskap
87      REAL tnat(ip1jmp1, llm)      REAL tnat(ip1jmp1, llm)
88    
89        LOGICAL:: first = .TRUE.
     LOGICAL first  
     SAVE first  
     DATA first/ .TRUE./  
90    
91      SAVE ucovrea1, vcovrea1, tetarea1, psrea1, qrea1      SAVE ucovrea1, vcovrea1, tetarea1, psrea1, qrea1
92      SAVE ucovrea2, vcovrea2, tetarea2, masserea2, psrea2, qrea2      SAVE ucovrea2, vcovrea2, tetarea2, masserea2, psrea2, qrea2
# Line 110  CONTAINS Line 106  CONTAINS
106    
107      ! calcul de l'humidite saturante      ! calcul de l'humidite saturante
108    
109      CALL pression(ip1jmp1, ap, bp, ps, p)      forall (l = 1: llm + 1) p(:, l) = ap(l) + bp(l) * ps
110      CALL massdair(p, masse)      CALL massdair(p, masse)
111      PRINT *, 'OK1'      PRINT *, 'OK1'
112      CALL exner_hyb(ps, p, pks, pk, pkf)      CALL exner_hyb(ps, p, pks, pk, pkf)
# Line 310  CONTAINS Line 306  CONTAINS
306            ps(ij) = (1.-alpha_p(ij))*ps(ij) + alpha_p(ij)*a            ps(ij) = (1.-alpha_p(ij))*ps(ij) + alpha_p(ij)*a
307            IF (first .AND. ini_anal) ps(ij) = a            IF (first .AND. ini_anal) ps(ij) = a
308         END DO         END DO
309         CALL pression(ip1jmp1, ap, bp, ps, p)         forall (l = 1: llm + 1) p(:, l) = ap(l) + bp(l) * ps
310         CALL massdair(p, masse)         CALL massdair(p, masse)
311      END IF      END IF
312    
# Line 344  CONTAINS Line 340  CONTAINS
340    
341    END SUBROUTINE guide    END SUBROUTINE guide
342    
   !=======================================================================  
   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  
   
343  END MODULE guide_m  END MODULE guide_m
Legend:
Removed from v.36  
changed lines
  Added in v.39
  ViewVC Help
Powered by ViewVC 1.1.21