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