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