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