source: LMDZ.3.3/trunk/libf/dyn3d/calc_uvtq.F @ 507

Last change on this file since 507 was 2, checked in by lmdz, 25 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 4.6 KB
Line 
1      SUBROUTINE  calc_uvtq (scalarq, plev,xtlon,ylat,champi,jlat ,
2     ,  rlon,rlat, phislmd,pslmd,tslmd,pls,pk,pks,p,   champsor   )
3c
4c     Auteur :  P. Le Van 
5cc
6      IMPLICIT NONE
7c
8#include "dimensions.h"
9#include "paramet.h"
10#include "comconst.h"
11#include "comvert.h"
12#include "para_netcdf.h"
13
14      INTEGER  jlat
15
16      LOGICAl scalarq
17      REAL*8  plev(levs)
18      REAL    xtlon(lons),ylat(lats),champi(lons,lats,levs)
19      REAL    phislmd(iip1,jlat),rlon(iip1),rlat(jlat) ,
20     ,        pslmd(iip1,jlat),tslmd(iip1,jlat),pls(iip1,jlat,llm) ,
21     ,        pk(iip1,jlat,llm),pks(iip1,jlat),p(iip1,jlat,llmp1) ,
22     ,        champsor(iip1,jlat,llm),alpha(iip1,jjp1,llm),
23     ,        beta(iip1,jjp1,llm),pkf(iip1,jjp1,llm)
24c
25c
26      REAL champint(iip1,jjp1)
27      LOGICAL invlev,invlon,invlat
28      REAL  pmbar
29      INTEGER ip180
30      COMMON/invlog/invlev,invlon,invlat,ip180,pmbar
31
32      REAL  ps,phisol,ts
33      COMMON/deuxD/ps(lons,lats),phisol(lons,lats),ts(lons,lats)
34 
35      INTEGER l,i,j,lll,ind,iipjlat
36c
37      REAL uu(lons,lats,levs)
38      REAL phisolmd(iip1,jjp1)
39      SAVE phisolmd
40      REAL ax(levs),ay(levs),yder(levs),bx,by
41      REAL champhor(iip1,jjp1,levs)
42      REAL prefkap,unskap
43
44      EXTERNAL grille_m, gr_int_dyn, pression, exner_hyb, spline, splint
45c
46
47      IF( scalarq )  GO TO 100
48
49       CALL grille_m(lons, lats, xtlon, ylat, ps ,
50     ,               iim, jlat, rlon, rlat, champint )
51
52
53       CALL gr_int_dyn(champint, pslmd, iim, jlat )
54
55       CALL grille_m(lons, lats, xtlon, ylat, phisol,
56     ,             iim, jlat, rlon, rlat, champint  )
57       CALL gr_int_dyn(champint, phisolmd, iim, jlat )
58
59       CALL grille_m(lons, lats, xtlon, ylat, ts,
60     ,             iim, jlat, rlon, rlat, champint)
61       CALL gr_int_dyn(champint, tslmd, iim, jlat  )
62
63       DO j = 1, jlat
64       DO i = 1, iim
65        pslmd(i,j)    = pslmd(i,j)*( 1.0+ (phisolmd(i,j)-phislmd(i,j))
66     ,                             /287.0/tslmd(i,j))
67       ENDDO
68        pslmd(iip1,j) = pslmd(1,j)
69       ENDDO
70
71       iipjlat = iip1 * jlat
72       CALL pression( iipjlat, ap, bp, pslmd, p )
73
74       CALL exner_hyb(iipjlat,pslmd,p,alpha,beta,pks,pk,pkf )
75
76
77c    ....  Calcul de pls , pression au milieu des couches ,en Pascals ....
78c
79      PRINT *,' Pref kappa unskap  ',preff,kappa
80
81      prefkap =  preff  ** kappa
82      unskap  =  1./ kappa
83
84       DO l = 1, llm
85        DO j = 1,jlat
86         DO i = 1, iim
87          pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
88         ENDDO
89          pls(iip1,j,l) = pls(1,j,l)
90        ENDDO
91       ENDDO
92
93c
94 100   CONTINUE
95c
96c
97       DO l = 1, levs
98        DO j = 1, lats
99          DO i= 1, lons
100           uu (i,j,l) = champi (i,j,l)
101          ENDDO
102        ENDDO
103       ENDDO
104
105        IF ( invlon )   THEN
106c
107c   .....    on tourne les longitudes  pour  avoir de - pi a pi ....
108c
109
110         DO l = 1, levs
111          DO j = 1,lats
112
113           DO i = ip180,lons
114           ind  = i-ip180 +1
115           uu (ind,j,l) = champi (i,j,l)
116           ENDDO
117   
118           DO i= ind +1,lons
119           uu (i,j,l)  = champi (i-ind,j,l)
120           ENDDO
121
122          ENDDO
123        ENDDO
124
125        ENDIF
126c
127
128c   *****   fin  de   IF(invlon)   ****
129         
130         DO l = 1, levs
131           DO j = 1, lats
132              DO i = 1, lons
133               champi (i,j,l) = uu (i,j,l)
134              ENDDO
135           ENDDO
136         ENDDO
137
138         IF ( invlat )    THEN
139
140          DO l = 1, levs
141           DO j = 1, lats
142              DO i = 1, lons
143               champi (i,lats-j+1,l) = uu (i,j,l)
144              ENDDO
145           ENDDO
146          ENDDO
147
148         ENDIF
149
150c   .....   Interpol.  horizontale  ......
151c   **************************************
152c
153      DO l = 1, levs
154
155      CALL grille_m(lons, lats, xtlon, ylat, champi(1,1,l),
156     ,               iim, jlat, rlon, rlat, champint    )
157      lll = l
158      IF( invlev) lll = levs -l +1
159      CALL gr_int_dyn(champint, champhor(1,1,lll), iim, jlat)
160c
161      ENDDO
162
163c    ...  Interpolation  verticale ....   
164c    **********************************
165c
166cc   Interpolation verticale par spline
167
168c     pmbar = 100. ( si les donnees de pression sont en mb ) ou = 1.
169c
170
171      DO j=1,jlat
172        DO  i=1,iim
173          DO l=1,levs
174            ax(l)= plev(levs-l+1) *  pmbar
175            ay(l)= champhor(i,j,levs-l+1)
176          ENDDO
177          CALL spline (ax,ay,levs,1.e30,1.e30,yder)
178          DO  l=1,llm
179           bx = pls(i,j,llm-l+1)
180            CALL splint (ax,ay,yder,levs,bx,by)
181            champsor(i,j,llm-l+1)= by
182          ENDDO
183        ENDDO
184        DO l = 1, llm
185          champsor(iip1, j, l) = champsor(1, j, l)
186        ENDDO
187      ENDDO
188
189
190      RETURN
191      END
Note: See TracBrowser for help on using the repository browser.