/[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

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