Guide/Read_reanalyse/reanalyse2nat.f

subroutine reanalyse2nat(nlevnc,psi &
     ,unc,vnc,tnc,qnc,psnc,pl,u,v,t,q &
     ,ps,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 psi(iip1,jjp1)
  real u(iip1,jjp1,llm),v(iip1,jjm,llm)
  real t(iip1,jjp1,llm),ps(iip1,jjp1),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

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

  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

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