/[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 44 by guez, Wed Apr 13 12:29:18 2011 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    module reanalyse2nat_m
2    
3      implicit none
4    
5  !===========================================================================  contains
6        subroutine reanalyse2nat(nlevnc,psi &  
7           ,unc,vnc,tnc,qnc,psnc,pl,u,v,t,q &    subroutine reanalyse2nat(invert_y, psi, unc, vnc, tnc, qnc, pl, u, v, t, q, &
8           ,ps,masse,pk)         pk)
9  !===========================================================================  
10        ! Inversion nord-sud de la grille et interpolation verticale sur
11  ! -----------------------------------------------------------------      ! les niveaux du modèle.
12  !   Inversion Nord/sud de la grille + interpollation sur les niveaux  
13  !   verticaux du modele.      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 dimens_m      USE disvert_m, ONLY: ap, bp, preff
17        use paramet_m      USE exner_hyb_m, ONLY: exner_hyb
18        use comconst      use massbar_m, only: massbar
19        use comvert      use massdair_m, only: massdair
20        use comgeom      USE paramet_m, ONLY: iip1, jjp1, llmp1
21        use exner_hyb_m, only: exner_hyb      use pres2lev_m, only: pres2lev
22        use conf_guide_m  
23        logical, intent(in):: invert_y
24        implicit none      real, intent(in):: psi(:, :) ! (iip1, jjp1)
25    
26        real, intent(in):: unc(:, :, :) ! (iip1, jjp1, :)
27        integer nlevnc      real, intent(in):: vnc(:, :, :) ! (iip1, jjm, :)
28        real psi(iip1,jjp1)      real, intent(in):: tnc(:, :, :) ! (iip1, jjp1, :)
29        real u(iip1,jjp1,llm),v(iip1,jjm,llm)      real, intent(in):: qnc(:, :, :) ! (iip1, jjp1, :)
30        real t(iip1,jjp1,llm),ps(iip1,jjp1),q(iip1,jjp1,llm)      real, intent(in):: pl(:)
31    
32        real pl(nlevnc)      real, intent(out):: u(:, :, :) ! (iip1, jjp1, llm)
33        real unc(iip1,jjp1,nlevnc),vnc(iip1,jjm,nlevnc)      real, intent(out):: v(:, :, :) ! (iip1, jjm, llm)
34        real tnc(iip1,jjp1,nlevnc),psnc(iip1,jjp1)      real, intent(out):: t(:, :, :), q(:, :, :) ! (iip1, jjp1, llm)
35        real qnc(iip1,jjp1,nlevnc)      real, intent(out):: pk(:, :, :) ! (iip1, jjp1, llm)
36    
37        real zu(iip1,jjp1,llm),zv(iip1,jjm,llm)      ! Local:
38        real zt(iip1,jjp1,llm),zq(iip1,jjp1,llm)  
39        real zu(iip1, jjp1, llm), zv(iip1, jjm, llm)
40        real pext(iip1,jjp1,llm)      real zt(iip1, jjp1, llm), zq(iip1, jjp1, llm)
41        real pbarx(iip1,jjp1,llm),pbary(iip1,jjm,llm)  
42        real plunc(iip1,jjp1,llm),plvnc(iip1,jjm,llm)      real pext(iip1, jjp1, llm)
43        real plsnc(iip1,jjp1,llm)      real pbarx(iip1, jjp1, llm), pbary(iip1, jjm, llm)
44        real plunc(iip1, jjp1, llm), plvnc(iip1, jjm, llm)
45        real p(iip1,jjp1,llmp1),pk(iip1,jjp1,llm),pks(iip1,jjp1)      real plsnc(iip1, jjp1, llm)
46        real pkf(iip1,jjp1,llm)  
47        real masse(iip1,jjp1,llm),pls(iip1,jjp1,llm)      real p(iip1, jjp1, llmp1)
48        real prefkap,unskap      real pks(iip1, jjp1)
49        real pls(iip1, jjp1, llm)
50        real prefkap, unskap
51        integer i,j,l  
52        integer i, j, l
53    
54  ! -----------------------------------------------------------------      ! -----------------------------------------------------------------
55  !   calcul de la pression au milieu des couches.  
56  ! -----------------------------------------------------------------      ! calcul de la pression au milieu des couches
57        forall (l = 1: llm + 1) p(:, :, l) = ap(l) + bp(l) * psi
58        forall (l = 1: llm + 1) p(:, :, l) = ap(l) + bp(l) * psi      CALL exner_hyb(psi, p, pks, pk)
59        call massdair(p,masse)  
60        CALL exner_hyb(psi,p,pks,pk,pkf)      ! Calcul de pls, pression au milieu des couches, en Pascals
61        unskap=1./kappa
62  !    ....  Calcul de pls , pression au milieu des couches ,en Pascals      prefkap = preff ** kappa
63        unskap=1./kappa      DO l = 1, llm
64        prefkap =  preff  ** kappa         DO j=1, jjp1
65  !     PRINT *,' Pref kappa unskap  ',preff,kappa,unskap            DO i =1, iip1
66        DO l = 1, llm               pls(i, j, l) = preff * ( pk(i, j, l)/cpp) ** unskap
67         DO j=1,jjp1            ENDDO
         DO i =1, iip1  
         pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap  
         ENDDO  
        ENDDO  
68         ENDDO         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
 !   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  
116    
117        return  end module reanalyse2nat_m
       end  
Legend:
Removed from v.44  
changed lines
  Added in v.173
  ViewVC Help
Powered by ViewVC 1.1.21