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

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

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

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