Guide/Read_reanalyse/pres2lev.f

module pres2lev_m

  IMPLICIT NONE

contains

  SUBROUTINE pres2lev(varo, varn, lmo, lmn, po, pn, ni, nj)

    ! From LMDZ4/libf/dyn3d/pres2lev.F, v 1.1.1.1 2004/05/19 12:53:07

    ! interpolation lineaire pour passer
    ! a une nouvelle discretisation verticale pour
    ! les variables de GCM
    ! Francois Forget (01/1995)

    ! MOdif remy roca 12/97 pour passer de pres2sig

    ! Declarations:

    ! ARGUMENTS
    ! """""""""

    INTEGER, intent(in):: lmo ! dimensions ancienne couches (input)
    INTEGER lmn ! dimensions nouvelle couches (input)
    INTEGER lmomx ! dimensions ancienne couches (input)
    INTEGER lmnmx ! dimensions nouvelle couches (input)

    PARAMETER (lmomx=10000, lmnmx=10000)

    REAL, intent(in):: po(lmo) ! niveau de pression en millibars
    INTEGER ni, nj
    REAL pn(ni, nj, lmn) ! niveau de pression en pascals

    INTEGER i, j ! nombre de point horizontale (input)

    REAL varo(ni, nj, lmo) ! var dans l'ancienne grille (input)
    REAL varn(ni, nj, lmn) ! var dans la nouvelle grille (output)

    REAL zvaro(lmomx), zpo(lmomx)

    ! Autres variables
    ! """"""""""""""""
    INTEGER ln, lo
    REAL coef

    ! run

    DO i = 1, ni
       DO j = 1, nj
          ! a chaque point de grille correspond un nouveau sigma old
          ! qui vaut pres(l)/ps(i, j)
          DO lo = 1, lmo
             zpo(lo) = po(lmo+1-lo)
             zvaro(lo) = varo(i, j, lmo+1-lo)
          END DO

          DO ln = 1, lmn
             IF (pn(i, j, ln)>=zpo(1)) THEN
                varn(i, j, ln) = zvaro(1)
             ELSE IF (pn(i, j, ln)<=zpo(lmo)) THEN
                varn(i, j, ln) = zvaro(lmo)
             ELSE
                DO lo = 1, lmo - 1
                   IF ((pn(i, j, ln)<=zpo(lo)) .AND. (pn(i, j, ln)>zpo(lo+1))) THEN
                      coef = (pn(i, j, ln)-zpo(lo))/(zpo(lo+1)-zpo(lo))
                      varn(i, j, ln) = zvaro(lo) + coef*(zvaro(lo+1)-zvaro(lo))
                      ! print*, 'pn(', ln, ')=', pn(i, j, ln), varn(i, j, ln)
                   END IF
                END DO
             END IF
          END DO

       END DO
    END DO
    RETURN
  END SUBROUTINE pres2lev

end module pres2lev_m
1	module pres2lev_m
2
3	IMPLICIT NONE
4
5	contains
6
7	SUBROUTINE pres2lev(varo, varn, lmo, lmn, po, pn, ni, nj)
8
9	! From LMDZ4/libf/dyn3d/pres2lev.F, v 1.1.1.1 2004/05/19 12:53:07
10
11	! interpolation lineaire pour passer
12	! a une nouvelle discretisation verticale pour
13	! les variables de GCM
14	! Francois Forget (01/1995)
15
16	! MOdif remy roca 12/97 pour passer de pres2sig
17
18	! Declarations:
19
20	! ARGUMENTS
21	! """""""""
22
23	INTEGER, intent(in):: lmo ! dimensions ancienne couches (input)
24	INTEGER lmn ! dimensions nouvelle couches (input)
25	INTEGER lmomx ! dimensions ancienne couches (input)
26	INTEGER lmnmx ! dimensions nouvelle couches (input)
27
28	PARAMETER (lmomx=10000, lmnmx=10000)
29
30	REAL, intent(in):: po(lmo) ! niveau de pression en millibars
31	INTEGER ni, nj
32	REAL pn(ni, nj, lmn) ! niveau de pression en pascals
33
34	INTEGER i, j ! nombre de point horizontale (input)
35
36	REAL varo(ni, nj, lmo) ! var dans l'ancienne grille (input)
37	REAL varn(ni, nj, lmn) ! var dans la nouvelle grille (output)
38
39	REAL zvaro(lmomx), zpo(lmomx)
40
41	! Autres variables
42	! """"""""""""""""
43	INTEGER ln, lo
44	REAL coef
45
46	! run
47
48	DO i = 1, ni
49	DO j = 1, nj
50	! a chaque point de grille correspond un nouveau sigma old
51	! qui vaut pres(l)/ps(i, j)
52	DO lo = 1, lmo
53	zpo(lo) = po(lmo+1-lo)
54	zvaro(lo) = varo(i, j, lmo+1-lo)
55	END DO
56
57	DO ln = 1, lmn
58	IF (pn(i, j, ln)>=zpo(1)) THEN
59	varn(i, j, ln) = zvaro(1)
60	ELSE IF (pn(i, j, ln)<=zpo(lmo)) THEN
61	varn(i, j, ln) = zvaro(lmo)
62	ELSE
63	DO lo = 1, lmo - 1
64	IF ((pn(i, j, ln)<=zpo(lo)) .AND. (pn(i, j, ln)>zpo(lo+1))) THEN
65	coef = (pn(i, j, ln)-zpo(lo))/(zpo(lo+1)-zpo(lo))
66	varn(i, j, ln) = zvaro(lo) + coef*(zvaro(lo+1)-zvaro(lo))
67	! print*, 'pn(', ln, ')=', pn(i, j, ln), varn(i, j, ln)
68	END IF
69	END DO
70	END IF
71	END DO
72
73	END DO
74	END DO
75	RETURN
76	END SUBROUTINE pres2lev
77
78	end module pres2lev_m