/[lmdze]/trunk/libf/dyn3d/guide.f90
ViewVC logotype

Diff of /trunk/libf/dyn3d/guide.f90

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

revision 36 by guez, Thu Dec 2 17:11:04 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      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 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    
# Line 87  CONTAINS Line 85  CONTAINS
85      REAL unskap      REAL unskap
86      REAL tnat(ip1jmp1, llm)      REAL tnat(ip1jmp1, llm)
87    
88        LOGICAL:: first = .TRUE.
     LOGICAL first  
     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 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.36  
changed lines
  Added in v.37
  ViewVC Help
Powered by ViewVC 1.1.21