/[lmdze]/trunk/libf/dyn3d/limy.f
ViewVC logotype

Annotation of /trunk/libf/dyn3d/limy.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 32 - (hide annotations)
Tue Apr 6 17:52:58 2010 UTC (14 years, 1 month ago) by guez
File size: 4697 byte(s) 
Split "stringop.f90" into single-procedure files. Gathered files in directory
"IOIPSL/Stringop".

Split "flincom.f90" into "flincom.f90" and "flinget.f90". Removed
unused procedures from module "flincom". Removed unused argument
"filename" of procedure "flinopen_nozoom".

Removed unused files.

Split "grid_change.f90" into "grid_change.f90" and
"gr_phy_write_3d.f90".

Removed unused procedures from modules "calendar", "ioipslmpp",
"grid_atob", "gath_cpl" and "getincom". Removed unused procedures in
files "ppm3d.f" and "thermcell.f".

Split "mathelp.f90" into "mathelp.f90" and "mathop.f90".

Removed unused variable "dpres" of module "comvert".

Use argument "itau" instead of local variables "iadvtr" and "first" to
control algorithm in procedure "fluxstokenc".

Removed unused arguments of procedure "integrd".

Removed useless computations at the end of procedure "leapfrog".

Merged common block "matrfil" into module "parafilt".
1 guez 3 !
2     ! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/limy.F,v 1.1.1.1 2004/05/19 12:53:07 lmdzadmin Exp $
3     !
4     SUBROUTINE limy(s0,sy,sm,pente_max)
5     c
6     c Auteurs: P.Le Van, F.Hourdin, F.Forget
7     c
8     c ********************************************************************
9     c Shema d'advection " pseudo amont " .
10     c ********************************************************************
11     c q,w sont des arguments d'entree pour le s-pg ....
12     c dq sont des arguments de sortie pour le s-pg ....
13     c
14     c
15     c --------------------------------------------------------------------
16     use dimens_m
17     use paramet_m
18     use comconst
19     use comvert
20     use logic
21     use comgeom
22     IMPLICIT NONE
23     c
24     c
25     c
26     c Arguments:
27     c ----------
28     real pente_max
29     real s0(ip1jmp1,llm),sy(ip1jmp1,llm),sm(ip1jmp1,llm)
30     c
31     c Local
32     c ---------
33     c
34     INTEGER i,ij,l
35     c
36     REAL q(ip1jmp1,llm)
37     REAL airej2,airejjm,airescb(iim),airesch(iim)
38     real sigv,dyq(ip1jmp1),dyqv(ip1jm)
39     real adyqv(ip1jm),dyqmax(ip1jmp1)
40     REAL qbyv(ip1jm,llm)
41    
42     REAL qpns,qpsn,apn,aps,dyn1,dys1,dyn2,dys2
43     Logical extremum,first
44     save first
45    
46     real convpn,convps,convmpn,convmps
47     real sinlon(iip1),sinlondlon(iip1)
48     real coslon(iip1),coslondlon(iip1)
49     save sinlon,coslon,sinlondlon,coslondlon
50     c
51     c
52     REAL SSUM
53     integer ismax,ismin
54     EXTERNAL SSUM, convflu,ismin,ismax
55    
56     data first/.true./
57    
58     if(first) then
59     print*,'SCHEMA AMONT NOUVEAU'
60     first=.false.
61     do i=2,iip1
62     coslon(i)=cos(rlonv(i))
63     sinlon(i)=sin(rlonv(i))
64     coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
65     sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
66     enddo
67     coslon(1)=coslon(iip1)
68     coslondlon(1)=coslondlon(iip1)
69     sinlon(1)=sinlon(iip1)
70     sinlondlon(1)=sinlondlon(iip1)
71     endif
72    
73     c
74    
75     do l = 1, llm
76     c
77     DO ij=1,ip1jmp1
78     q(ij,l) = s0(ij,l) / sm ( ij,l )
79     dyq(ij) = sy(ij,l) / sm ( ij,l )
80     ENDDO
81     c
82     c --------------------------------
83     c CALCUL EN LATITUDE
84     c --------------------------------
85    
86     c On commence par calculer la valeur du traceur moyenne sur le premier cercle
87     c de latitude autour du pole (qpns pour le pole nord et qpsn pour
88     c le pole nord) qui sera utilisee pour evaluer les pentes au pole.
89    
90     airej2 = SSUM( iim, aire(iip2), 1 )
91     airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
92     DO i = 1, iim
93     airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
94     airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
95     ENDDO
96     qpns = SSUM( iim, airescb ,1 ) / airej2
97     qpsn = SSUM( iim, airesch ,1 ) / airejjm
98    
99     c calcul des pentes aux points v
100    
101     do ij=1,ip1jm
102     dyqv(ij)=q(ij,l)-q(ij+iip1,l)
103     adyqv(ij)=abs(dyqv(ij))
104     ENDDO
105    
106     c calcul des pentes aux points scalaires
107    
108     do ij=iip2,ip1jm
109     dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
110     dyqmax(ij)=pente_max*dyqmax(ij)
111     enddo
112    
113     c calcul des pentes aux poles
114    
115     c calcul des pentes limites aux poles
116    
117     c cas ou on a un extremum au pole
118    
119     c if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
120     c & apn=0.
121     c if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
122     c & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
123     c & aps=0.
124    
125     c limitation des pentes aux poles
126     c do ij=1,iip1
127     c dyq(ij)=apn*dyq(ij)
128     c dyq(ip1jm+ij)=aps*dyq(ip1jm+ij)
129     c enddo
130    
131     c test
132     c do ij=1,iip1
133     c dyq(iip1+ij)=0.
134     c dyq(ip1jm+ij-iip1)=0.
135     c enddo
136     c do ij=1,ip1jmp1
137     c dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
138     c enddo
139    
140     if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
141     & then
142     do ij=1,iip1
143     dyqmax(ij)=0.
144     enddo
145     else
146     do ij=1,iip1
147     dyqmax(ij)=pente_max*abs(dyqv(ij))
148     enddo
149     endif
150    
151     if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
152     & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
153     &then
154     do ij=ip1jm+1,ip1jmp1
155     dyqmax(ij)=0.
156     enddo
157     else
158     do ij=ip1jm+1,ip1jmp1
159     dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
160     enddo
161     endif
162    
163     c calcul des pentes limitees
164    
165     do ij=1,ip1jmp1
166     if(dyqv(ij)*dyqv(ij-iip1).gt.0.) then
167     dyq(ij)=sign(min(abs(dyq(ij)),dyqmax(ij)),dyq(ij))
168     else
169     dyq(ij)=0.
170     endif
171     enddo
172    
173     DO ij=1,ip1jmp1
174     sy(ij,l) = dyq(ij) * sm ( ij,l )
175     ENDDO
176    
177     enddo ! fin de la boucle sur les couches verticales
178    
179     RETURN
180     END
  ViewVC Help
Powered by ViewVC 1.1.21