/[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 178 by guez, Fri Mar 11 18:47:26 2016 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: 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 paramet_m, ONLY: iip1, jjp1, llmp1
20        use pres2lev_m, only: pres2lev
21    
22        logical, intent(in):: invert_y
23        real, intent(in):: psi(:, :) ! (iip1, jjp1)
24    
25        real, intent(in):: unc(:, :, :) ! (iip1, jjp1, :)
26        real, intent(in):: vnc(:, :, :) ! (iip1, jjm, :)
27        real, intent(in):: tnc(:, :, :) ! (iip1, jjp1, :)
28        real, intent(in):: qnc(:, :, :) ! (iip1, jjp1, :)
29        real, intent(in):: pl(:)
30    
31        real, intent(out):: u(:, :, :) ! (iip1, jjp1, llm)
32        real, intent(out):: v(:, :, :) ! (iip1, jjm, llm)
33        real, intent(out):: t(:, :, :), q(:, :, :) ! (iip1, jjp1, llm)
34        real, intent(out):: pk(:, :, :) ! (iip1, jjp1, llm)
35    
36        ! Local:
37    
38        real zu(iip1, jjp1, llm), zv(iip1, jjm, llm)
39        real zt(iip1, jjp1, llm), zq(iip1, jjp1, llm)
40    
41        real pext(iip1, jjp1, llm)
42        real pbarx(iip1, jjp1, llm), pbary(iip1, jjm, llm)
43        real plunc(iip1, jjp1, llm), plvnc(iip1, jjm, llm)
44        real plsnc(iip1, jjp1, llm)
45    
46        real p(iip1, jjp1, llmp1)
47        real pks(iip1, jjp1)
48        real pls(iip1, jjp1, llm)
49        real unskap
50    
51        integer i, j, l
52    
53        ! -----------------------------------------------------------------
54    
55        ! calcul de la pression au milieu des couches
56        forall (l = 1: llm + 1) p(:, :, l) = ap(l) + bp(l) * psi
57        CALL exner_hyb(psi, p, pks, pk)
58    
59        ! Calcul de pls, pression au milieu des couches, en Pascals
60        unskap=1./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, pl, plunc)
96        call pres2lev(vnc, zv, pl, plvnc )
97        call pres2lev(tnc, zt, pl, plsnc)
98        call pres2lev(qnc, zq, pl, plsnc)
99    
100        if (invert_y) then
101           ! Inversion Nord/Sud
102           u=zu(:, jjp1:1:-1, :)
103           v=zv(:, jjm:1:-1, :)
104           t=zt(:, jjp1:1:-1, :)
105           q=zq(:, jjp1:1:-1, :)
106        else
107           u = zu
108           v = zv
109           t = zt
110           q = zq
111        end if
112    
113      end subroutine reanalyse2nat
114    
115    end module reanalyse2nat_m
Legend:
Removed from v.67  
changed lines
  Added in v.178
  ViewVC Help
Powered by ViewVC 1.1.21