/[lmdze]/trunk/Sources/dyn3d/Guide/Read_reanalyse/reanalyse2nat.f
ViewVC logotype

Diff of /trunk/Sources/dyn3d/Guide/Read_reanalyse/reanalyse2nat.f

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

trunk/dyn3d/Read_reanalyse/reanalyse2nat.f90 revision 76 by guez, Fri Nov 15 18:45:49 2013 UTC trunk/Sources/dyn3d/Guide/Read_reanalyse/reanalyse2nat.f revision 173 by guez, Tue Oct 6 15:57:02 2015 UTC
# Line 1  Line 1 
1  subroutine reanalyse2nat(nlevnc,psi &  module reanalyse2nat_m
      ,unc,vnc,tnc,qnc,psnc,pl,u,v,t,q &  
      ,ps,masse,pk)  
   
   !   Inversion Nord/sud de la grille + interpollation sur les niveaux  
   !   verticaux du modele.  
   ! -----------------------------------------------------------------  
   
   use dimens_m  
   use paramet_m  
   use comconst  
   use disvert_m  
   use comgeom  
   use exner_hyb_m, only: exner_hyb  
   use conf_guide_m  
   use massdair_m, only: massdair  
2    
3    implicit none    implicit none
4    
5    contains
6    
7    integer nlevnc    subroutine reanalyse2nat(invert_y, psi, unc, vnc, tnc, qnc, pl, u, v, t, q, &
8    real psi(iip1,jjp1)         pk)
   real u(iip1,jjp1,llm),v(iip1,jjm,llm)  
   real t(iip1,jjp1,llm),ps(iip1,jjp1),q(iip1,jjp1,llm)  
   
   real pl(nlevnc)  
   real unc(iip1,jjp1,nlevnc),vnc(iip1,jjm,nlevnc)  
   real tnc(iip1,jjp1,nlevnc),psnc(iip1,jjp1)  
   real qnc(iip1,jjp1,nlevnc)  
   
   real zu(iip1,jjp1,llm),zv(iip1,jjm,llm)  
   real zt(iip1,jjp1,llm),zq(iip1,jjp1,llm)  
   
   real pext(iip1,jjp1,llm)  
   real pbarx(iip1,jjp1,llm),pbary(iip1,jjm,llm)  
   real plunc(iip1,jjp1,llm),plvnc(iip1,jjm,llm)  
   real plsnc(iip1,jjp1,llm)  
   
   real p(iip1,jjp1,llmp1),pk(iip1,jjp1,llm),pks(iip1,jjp1)  
   real pkf(iip1,jjp1,llm)  
   real masse(iip1,jjp1,llm),pls(iip1,jjp1,llm)  
   real prefkap,unskap  
   
   
   integer i,j,l  
   
   
   ! -----------------------------------------------------------------  
   !   calcul de la pression au milieu des couches.  
   ! -----------------------------------------------------------------  
   
   forall (l = 1: llm + 1) p(:, :, l) = ap(l) + bp(l) * psi  
   call massdair(p,masse)  
   CALL exner_hyb(psi,p,pks,pk,pkf)  
   
   !    ....  Calcul de pls , pression au milieu des couches ,en Pascals  
   unskap=1./kappa  
   prefkap =  preff  ** kappa  
   !     PRINT *,' Pref kappa unskap  ',preff,kappa,unskap  
   DO l = 1, llm  
      DO j=1,jjp1  
         DO i =1, iip1  
            pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap  
         ENDDO  
      ENDDO  
   ENDDO  
   
   
   ! -----------------------------------------------------------------  
   !   calcul des pressions pour les grilles u et v  
   ! -----------------------------------------------------------------  
   
   do l=1,llm  
      do j=1,jjp1  
         do i=1,iip1  
            pext(i,j,l)=pls(i,j,l)*aire_2d(i,j)  
         enddo  
      enddo  
   enddo  
   call massbar(pext, pbarx, pbary )  
   do l=1,llm  
      do j=1,jjp1  
         do i=1,iip1  
            plunc(i,jjp1+1-j,l)=pbarx(i,j,l)/aireu_2d(i,j)  
            plsnc(i,jjp1+1-j,l)=pls(i,j,l)  
         enddo  
      enddo  
   enddo  
   do l=1,llm  
      do j=1,jjm  
         do i=1,iip1  
            plvnc(i,jjm+1-j,l)=pbary(i,j,l)/airev_2d(i,j)  
         enddo  
      enddo  
   enddo  
   
   ! -----------------------------------------------------------------  
   
   if (guide_P) then  
      do j=1,jjp1  
         do i=1,iim  
            ps(i,j)=psnc(i,jjp1+1-j)  
         enddo  
         ps(iip1,j)=ps(1,j)  
      enddo  
   endif  
   
   
   ! -----------------------------------------------------------------  
   call pres2lev(unc,zu,nlevnc,llm,pl,plunc,iip1,jjp1)  
   call pres2lev(vnc,zv,nlevnc,llm,pl,plvnc,iip1,jjm )  
   call pres2lev(tnc,zt,nlevnc,llm,pl,plsnc,iip1,jjp1)  
   call pres2lev(qnc,zq,nlevnc,llm,pl,plsnc,iip1,jjp1)  
   
   !     call dump2d(iip1,jjp1,ps,'PS    ')  
   !     call dump2d(iip1,jjp1,psu,'PS    ')  
   !     call dump2d(iip1,jjm,psv,'PS    ')  
   !  Inversion Nord/Sud  
   do l=1,llm  
      do j=1,jjp1  
         do i=1,iim  
            u(i,j,l)=zu(i,jjp1+1-j,l)  
            t(i,j,l)=zt(i,jjp1+1-j,l)  
            q(i,j,l)=zq(i,jjp1+1-j,l)  
         enddo  
         u(iip1,j,l)=u(1,j,l)  
         t(iip1,j,l)=t(1,j,l)  
         q(iip1,j,l)=q(1,j,l)  
      enddo  
   enddo  
   
   do l=1,llm  
      do j=1,jjm  
         do i=1,iim  
            v(i,j,l)=zv(i,jjm+1-j,l)  
         enddo  
         v(iip1,j,l)=v(1,j,l)  
      enddo  
   enddo  
9    
10  end subroutine reanalyse2nat      ! Inversion nord-sud de la grille et interpolation verticale sur
11        ! les niveaux du modèle.
12    
13        USE comconst, ONLY: cpp, kappa
14        USE comgeom, ONLY: aireu_2d, airev_2d, aire_2d
15        USE dimens_m, ONLY: iim, jjm, llm
16        USE disvert_m, ONLY: ap, bp, preff
17        USE exner_hyb_m, ONLY: exner_hyb
18        use massbar_m, only: massbar
19        use massdair_m, only: massdair
20        USE paramet_m, ONLY: iip1, jjp1, llmp1
21        use pres2lev_m, only: pres2lev
22    
23        logical, intent(in):: invert_y
24        real, intent(in):: psi(:, :) ! (iip1, jjp1)
25    
26        real, intent(in):: unc(:, :, :) ! (iip1, jjp1, :)
27        real, intent(in):: vnc(:, :, :) ! (iip1, jjm, :)
28        real, intent(in):: tnc(:, :, :) ! (iip1, jjp1, :)
29        real, intent(in):: qnc(:, :, :) ! (iip1, jjp1, :)
30        real, intent(in):: pl(:)
31    
32        real, intent(out):: u(:, :, :) ! (iip1, jjp1, llm)
33        real, intent(out):: v(:, :, :) ! (iip1, jjm, llm)
34        real, intent(out):: t(:, :, :), q(:, :, :) ! (iip1, jjp1, llm)
35        real, intent(out):: pk(:, :, :) ! (iip1, jjp1, llm)
36    
37        ! Local:
38    
39        real zu(iip1, jjp1, llm), zv(iip1, jjm, llm)
40        real zt(iip1, jjp1, llm), zq(iip1, jjp1, llm)
41    
42        real pext(iip1, jjp1, llm)
43        real pbarx(iip1, jjp1, llm), pbary(iip1, jjm, llm)
44        real plunc(iip1, jjp1, llm), plvnc(iip1, jjm, llm)
45        real plsnc(iip1, jjp1, llm)
46    
47        real p(iip1, jjp1, llmp1)
48        real pks(iip1, jjp1)
49        real pls(iip1, jjp1, llm)
50        real prefkap, unskap
51    
52        integer i, j, l
53    
54        ! -----------------------------------------------------------------
55    
56        ! calcul de la pression au milieu des couches
57        forall (l = 1: llm + 1) p(:, :, l) = ap(l) + bp(l) * psi
58        CALL exner_hyb(psi, p, pks, pk)
59    
60        ! Calcul de pls, pression au milieu des couches, en Pascals
61        unskap=1./kappa
62        prefkap = preff ** kappa
63        DO l = 1, llm
64           DO j=1, jjp1
65              DO i =1, iip1
66                 pls(i, j, l) = preff * ( pk(i, j, l)/cpp) ** unskap
67              ENDDO
68           ENDDO
69        ENDDO
70    
71        ! calcul des pressions pour les grilles u et v
72    
73        do l=1, llm
74           do j=1, jjp1
75              do i=1, iip1
76                 pext(i, j, l)=pls(i, j, l)*aire_2d(i, j)
77              enddo
78           enddo
79        enddo
80        call massbar(pext, pbarx, pbary )
81        do l=1, llm
82           do j=1, jjp1
83              do i=1, iip1
84                 plunc(i, jjp1+1-j, l)=pbarx(i, j, l)/aireu_2d(i, j)
85                 plsnc(i, jjp1+1-j, l)=pls(i, j, l)
86              enddo
87           enddo
88        enddo
89        do l=1, llm
90           do j=1, jjm
91              do i=1, iip1
92                 plvnc(i, jjm+1-j, l)=pbary(i, j, l)/airev_2d(i, j)
93              enddo
94           enddo
95        enddo
96    
97        call pres2lev(unc, zu, pl, plunc)
98        call pres2lev(vnc, zv, pl, plvnc )
99        call pres2lev(tnc, zt, pl, plsnc)
100        call pres2lev(qnc, zq, pl, plsnc)
101    
102        if (invert_y) then
103           ! Inversion Nord/Sud
104           u=zu(:, jjp1:1:-1, :)
105           v=zv(:, jjm:1:-1, :)
106           t=zt(:, jjp1:1:-1, :)
107           q=zq(:, jjp1:1:-1, :)
108        else
109           u = zu
110           v = zv
111           t = zt
112           q = zq
113        end if
114    
115      end subroutine reanalyse2nat
116    
117    end module reanalyse2nat_m
Legend:
Removed from v.76  
changed lines
  Added in v.173
  ViewVC Help
Powered by ViewVC 1.1.21