Guide/Read_reanalyse/reanalyse2nat.f

subroutine reanalyse2nat(nlevnc,psi,unc,vnc,tnc,qnc,psnc,pl,u,v,t,q ,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

  implicit none


  integer nlevnc
  real, intent(in):: psi(iip1,jjp1)
  real u(iip1,jjp1,llm),v(iip1,jjm,llm)
  real t(iip1,jjp1,llm), 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

  ! -----------------------------------------------------------------

  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)

  !  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

end subroutine reanalyse2nat
1	guez	85	subroutine reanalyse2nat(nlevnc,psi,unc,vnc,tnc,qnc,psnc,pl,u,v,t,q ,masse,pk)
2	guez	37
3	guez	67	! Inversion Nord/sud de la grille + interpollation sur les niveaux
4			! verticaux du modele.
5			! -----------------------------------------------------------------
6	guez	37
7	guez	67	use dimens_m
8			use paramet_m
9			use comconst
10			use disvert_m
11			use comgeom
12			use exner_hyb_m, only: exner_hyb
13			use conf_guide_m
14			use massdair_m, only: massdair
15	guez	37
16	guez	67	implicit none
17	guez	37
18
19	guez	67	integer nlevnc
20	guez	83	real, intent(in):: psi(iip1,jjp1)
21	guez	67	real u(iip1,jjp1,llm),v(iip1,jjm,llm)
22	guez	85	real t(iip1,jjp1,llm), q(iip1,jjp1,llm)
23	guez	37
24	guez	67	real pl(nlevnc)
25			real unc(iip1,jjp1,nlevnc),vnc(iip1,jjm,nlevnc)
26			real tnc(iip1,jjp1,nlevnc),psnc(iip1,jjp1)
27			real qnc(iip1,jjp1,nlevnc)
28	guez	37
29	guez	67	real zu(iip1,jjp1,llm),zv(iip1,jjm,llm)
30			real zt(iip1,jjp1,llm),zq(iip1,jjp1,llm)
31	guez	37
32	guez	67	real pext(iip1,jjp1,llm)
33			real pbarx(iip1,jjp1,llm),pbary(iip1,jjm,llm)
34			real plunc(iip1,jjp1,llm),plvnc(iip1,jjm,llm)
35			real plsnc(iip1,jjp1,llm)
36	guez	37
37	guez	67	real p(iip1,jjp1,llmp1),pk(iip1,jjp1,llm),pks(iip1,jjp1)
38			real pkf(iip1,jjp1,llm)
39			real masse(iip1,jjp1,llm),pls(iip1,jjp1,llm)
40			real prefkap,unskap
41	guez	37
42
43	guez	67	integer i,j,l
44	guez	37
45
46	guez	67	! -----------------------------------------------------------------
47			! calcul de la pression au milieu des couches.
48			! -----------------------------------------------------------------
49	guez	37
50	guez	67	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	guez	37
54	guez	67	! .... Calcul de pls , pression au milieu des couches ,en Pascals
55			unskap=1./kappa
56			prefkap = preff ** kappa
57			! PRINT *,' Pref kappa unskap ',preff,kappa,unskap
58			DO l = 1, llm
59			DO j=1,jjp1
60	guez	37	DO i =1, iip1
61	guez	67	pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
62	guez	37	ENDDO
63	guez	67	ENDDO
64			ENDDO
65	guez	37
66
67	guez	67	! -----------------------------------------------------------------
68			! calcul des pressions pour les grilles u et v
69			! -----------------------------------------------------------------
70	guez	37
71	guez	67	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	guez	37
95	guez	67	! -----------------------------------------------------------------
96	guez	37
97	guez	67	call pres2lev(unc,zu,nlevnc,llm,pl,plunc,iip1,jjp1)
98			call pres2lev(vnc,zv,nlevnc,llm,pl,plvnc,iip1,jjm )
99			call pres2lev(tnc,zt,nlevnc,llm,pl,plsnc,iip1,jjp1)
100			call pres2lev(qnc,zq,nlevnc,llm,pl,plsnc,iip1,jjp1)
101	guez	37
102	guez	67	! Inversion Nord/Sud
103			do l=1,llm
104			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			q(i,j,l)=zq(i,jjp1+1-j,l)
109			enddo
110			u(iip1,j,l)=u(1,j,l)
111			t(iip1,j,l)=t(1,j,l)
112			q(iip1,j,l)=q(1,j,l)
113			enddo
114			enddo
115	guez	37
116	guez	67	do l=1,llm
117			do j=1,jjm
118			do i=1,iim
119			v(i,j,l)=zv(i,jjm+1-j,l)
120			enddo
121			v(iip1,j,l)=v(1,j,l)
122			enddo
123			enddo
124	guez	37
125	guez	67	end subroutine reanalyse2nat