source: LMDZ5/branches/LMDZ6_rc0/libf/phylmd/plevel_new.F90 @ 2687

Last change on this file since 2687 was 2283, checked in by Laurent Fairhead, 9 years ago

Backport of trunk revisions 2271, 2279, 2280, 2282 into LMDZ6_rc0 branch:

  • modifications for NMC/XIOS
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 4.0 KB
Line 
1
2! $Header: /home/cvsroot/LMDZ4/libf/phylmd/plevel.F,v 1.1.1.1.10.1 2006/08/17
3! 15:41:51 fairhead Exp $
4
5! ================================================================
6! ================================================================
7SUBROUTINE plevel_new(ilon, ilev, klevstd, lnew, pgcm, pres, qgcm, qpres)
8  ! ================================================================
9  ! ================================================================
10  USE netcdf
11  USE dimphy
12#ifdef CPP_IOIPSL
13  USE phys_state_var_mod, ONLY: missing_val_nf90
14#endif
15#ifdef CPP_XIOS
16  USE wxios, ONLY: missing_val
17#endif
18
19  IMPLICIT NONE
20
21  ! ym#include "dimensions.h"
22  ! y#include "dimphy.h"
23
24  ! ================================================================
25
26  ! Interpoler des champs 3-D u, v et g du modele a un niveau de
27  ! pression donnee (pres)
28
29  ! INPUT:  ilon ----- nombre de points
30  ! ilev ----- nombre de couches
31  ! lnew ----- true si on doit reinitialiser les poids
32  ! pgcm ----- pressions modeles
33  ! pres ----- pression vers laquelle on interpolle
34  ! Qgcm ----- champ GCM
35  ! Qpres ---- champ interpolle au niveau pres
36
37  ! ================================================================
38
39  ! arguments :
40  ! -----------
41
42  INTEGER ilon, ilev, klevstd
43  LOGICAL lnew
44
45  REAL pgcm(ilon, ilev)
46  REAL qgcm(ilon, ilev)
47  REAL pres(klevstd)
48  REAL qpres(ilon, klevstd)
49
50  ! local :
51  ! -------
52
53  ! ym      INTEGER lt(klon), lb(klon)
54  ! ym      REAL ptop, pbot, aist(klon), aisb(klon)
55
56  ! ym      save lt,lb,ptop,pbot,aist,aisb
57  INTEGER, ALLOCATABLE, SAVE, DIMENSION (:, :) :: lt, lb
58  REAL, ALLOCATABLE, SAVE, DIMENSION (:, :) :: aist, aisb
59  !$OMP THREADPRIVATE(lt,lb,aist,aisb)
60  REAL, SAVE :: ptop, pbot
61  !$OMP THREADPRIVATE(ptop, pbot)
62  LOGICAL, SAVE :: first = .TRUE.
63  INTEGER :: nlev
64  !$OMP THREADPRIVATE(first)
65  INTEGER i, k
66
67! REAL missing_val
68#ifndef CPP_XIOS
69  REAL :: missing_val
70#endif
71
72! missing_val = nf90_fill_real
73
74#ifndef CPP_XIOS
75      missing_val=missing_val_nf90
76#endif
77
78  IF (first) THEN
79    ALLOCATE (lt(klon,klevstd), lb(klon,klevstd))
80    ALLOCATE (aist(klon,klevstd), aisb(klon,klevstd))
81    first = .FALSE.
82  END IF
83
84  ! =====================================================================
85  IF (lnew) THEN
86    ! on reinitialise les reindicages et les poids
87    ! =====================================================================
88
89
90    ! Chercher les 2 couches les plus proches du niveau a obtenir
91
92    ! Eventuellement, faire l'extrapolation a partir des deux couches
93    ! les plus basses ou les deux couches les plus hautes:
94
95
96    DO nlev = 1, klevstd
97      DO i = 1, klon
98        IF (abs(pres(nlev)-pgcm(i,ilev))<abs(pres(nlev)-pgcm(i,1))) THEN
99          lt(i, nlev) = ilev ! 2
100          lb(i, nlev) = ilev - 1 ! 1
101        ELSE
102          lt(i, nlev) = 2
103          lb(i, nlev) = 1
104        END IF
105      END DO
106      DO k = 1, ilev - 1
107        DO i = 1, klon
108          pbot = pgcm(i, k)
109          ptop = pgcm(i, k+1)
110          IF (ptop<=pres(nlev) .AND. pbot>=pres(nlev)) THEN
111            lt(i, nlev) = k + 1
112            lb(i, nlev) = k
113          END IF
114        END DO
115      END DO
116
117      ! Interpolation lineaire:
118      DO i = 1, klon
119        ! interpolation en logarithme de pression:
120
121        ! ...   Modif . P. Le Van    ( 20/01/98) ....
122        ! Modif Frederic Hourdin (3/01/02)
123
124        aist(i, nlev) = log(pgcm(i,lb(i,nlev))/pres(nlev))/log(pgcm(i,lb(i, &
125          nlev))/pgcm(i,lt(i,nlev)))
126        aisb(i, nlev) = log(pres(nlev)/pgcm(i,lt(i,nlev)))/log(pgcm(i,lb(i, &
127          nlev))/pgcm(i,lt(i,nlev)))
128      END DO
129    END DO
130
131  END IF ! lnew
132
133  ! ======================================================================
134  ! inteprollation
135  ! ET je mets les vents a zero quand je rencontre une montagne
136  ! ======================================================================
137
138  DO nlev = 1, klevstd
139    DO i = 1, klon
140      IF (pgcm(i,1)<pres(nlev)) THEN
141        qpres(i, nlev) = missing_val
142      ELSE
143        qpres(i, nlev) = qgcm(i, lb(i,nlev))*aisb(i, nlev) + &
144          qgcm(i, lt(i,nlev))*aist(i, nlev)
145      END IF
146    END DO
147  END DO
148
149
150  RETURN
151END SUBROUTINE plevel_new
Note: See TracBrowser for help on using the repository browser.