/[lmdze]/trunk/Sources/dyn3d/limx.f
ViewVC logotype

Diff of /trunk/Sources/dyn3d/limx.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/libf/dyn3d/limx.f revision 27 by guez, Thu Mar 25 14:29:07 2010 UTC trunk/Sources/dyn3d/limx.f revision 157 by guez, Mon Jul 20 16:01:49 2015 UTC
# Line 1  Line 1 
 !  
 ! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/limx.F,v 1.1.1.1 2004/05/19 12:53:06 lmdzadmin Exp $  
 !  
       SUBROUTINE limx(s0,sx,sm,pente_max)  
 c  
 c     Auteurs:   P.Le Van, F.Hourdin, F.Forget  
 c  
 c    ********************************************************************  
 c     Shema  d'advection " pseudo amont " .  
 c    ********************************************************************  
 c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....  
 c  
 c  
 c   --------------------------------------------------------------------  
       use dimens_m  
       use paramet_m  
       use comconst  
       use comvert  
       use logic  
       use comgeom  
       IMPLICIT NONE  
 c  
 c  
 c  
 c   Arguments:  
 c   ----------  
       real pente_max  
       REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm)  
       real sx(ip1jmp1,llm)  
 c  
 c      Local  
 c   ---------  
 c  
       INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju  
       integer n0,iadvplus(ip1jmp1,llm),nl(llm)  
 c  
       REAL q(ip1jmp1,llm)  
       real dxq(ip1jmp1,llm)  
   
   
       REAL new_m,zm  
       real dxqu(ip1jmp1)  
       real adxqu(ip1jmp1),dxqmax(ip1jmp1)  
   
       Logical extremum,first  
       save first  
   
       REAL      SSUM,CVMGP,CVMGT  
       integer ismax,ismin  
       EXTERNAL  SSUM, convflu,ismin,ismax  
   
       data first/.true./  
   
   
        DO  l = 1,llm  
          DO  ij=1,ip1jmp1  
                q(ij,l) = s0(ij,l) / sm ( ij,l )  
                dxq(ij,l) = sx(ij,l) /sm(ij,l)  
          ENDDO  
        ENDDO  
   
 c   calcul de la pente a droite et a gauche de la maille  
   
       do l = 1, llm  
          do ij=iip2,ip1jm-1  
             dxqu(ij)=q(ij+1,l)-q(ij,l)  
          enddo  
          do ij=iip1+iip1,ip1jm,iip1  
             dxqu(ij)=dxqu(ij-iim)  
          enddo  
   
          do ij=iip2,ip1jm  
             adxqu(ij)=abs(dxqu(ij))  
          enddo  
   
 c   calcul de la pente maximum dans la maille en valeur absolue  
   
          do ij=iip2+1,ip1jm  
             dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij))  
          enddo  
   
          do ij=iip1+iip1,ip1jm,iip1  
             dxqmax(ij-iim)=dxqmax(ij)  
          enddo  
   
 c   calcul de la pente avec limitation  
   
          do ij=iip2+1,ip1jm  
             if(     dxqu(ij-1)*dxqu(ij).gt.0.  
      &         .and. dxq(ij,l)*dxqu(ij).gt.0.) then  
               dxq(ij,l)=  
      &         sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l))  
             else  
 c   extremum local  
                dxq(ij,l)=0.  
             endif  
          enddo  
          do ij=iip1+iip1,ip1jm,iip1  
             dxq(ij-iim,l)=dxq(ij,l)  
          enddo  
   
          DO  ij=1,ip1jmp1  
                sx(ij,l) = dxq(ij,l)*sm(ij,l)  
          ENDDO  
1    
2         ENDDO  ! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/limx.F,v 1.1.1.1 2004/05/19
3    ! 12:53:06 lmdzadmin Exp $
4    
5        RETURN  SUBROUTINE limx(s0, sx, sm, pente_max)
6        END  
7      ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
8    
9      ! ********************************************************************
10      ! Shema  d'advection " pseudo amont " .
11      ! ********************************************************************
12      ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
13    
14    
15      ! --------------------------------------------------------------------
16      USE dimens_m
17      USE paramet_m
18      USE comconst
19      USE disvert_m
20      USE conf_gcm_m
21      USE comgeom
22      IMPLICIT NONE
23    
24    
25    
26      ! Arguments:
27      ! ----------
28      REAL pente_max
29      REAL s0(ip1jmp1, llm), sm(ip1jmp1, llm)
30      REAL sx(ip1jmp1, llm)
31    
32      ! Local
33      ! ---------
34    
35      INTEGER ij, l
36    
37      REAL q(ip1jmp1, llm)
38      REAL dxq(ip1jmp1, llm)
39    
40      REAL dxqu(ip1jmp1)
41      REAL adxqu(ip1jmp1), dxqmax(ip1jmp1)
42    
43      REAL ssum
44      INTEGER ismax, ismin
45      EXTERNAL ssum, convflu, ismin, ismax
46    
47      DO l = 1, llm
48        DO ij = 1, ip1jmp1
49          q(ij, l) = s0(ij, l)/sm(ij, l)
50          dxq(ij, l) = sx(ij, l)/sm(ij, l)
51        END DO
52      END DO
53    
54      ! calcul de la pente a droite et a gauche de la maille
55    
56      DO l = 1, llm
57        DO ij = iip2, ip1jm - 1
58          dxqu(ij) = q(ij+1, l) - q(ij, l)
59        END DO
60        DO ij = iip1 + iip1, ip1jm, iip1
61          dxqu(ij) = dxqu(ij-iim)
62        END DO
63    
64        DO ij = iip2, ip1jm
65          adxqu(ij) = abs(dxqu(ij))
66        END DO
67    
68        ! calcul de la pente maximum dans la maille en valeur absolue
69    
70        DO ij = iip2 + 1, ip1jm
71          dxqmax(ij) = pente_max*min(adxqu(ij-1), adxqu(ij))
72        END DO
73    
74        DO ij = iip1 + iip1, ip1jm, iip1
75          dxqmax(ij-iim) = dxqmax(ij)
76        END DO
77    
78        ! calcul de la pente avec limitation
79    
80        DO ij = iip2 + 1, ip1jm
81          IF (dxqu(ij-1)*dxqu(ij)>0. .AND. dxq(ij,l)*dxqu(ij)>0.) THEN
82            dxq(ij, l) = sign(min(abs(dxq(ij,l)),dxqmax(ij)), dxq(ij,l))
83          ELSE
84            ! extremum local
85            dxq(ij, l) = 0.
86          END IF
87        END DO
88        DO ij = iip1 + iip1, ip1jm, iip1
89          dxq(ij-iim, l) = dxq(ij, l)
90        END DO
91    
92        DO ij = 1, ip1jmp1
93          sx(ij, l) = dxq(ij, l)*sm(ij, l)
94        END DO
95    
96      END DO
97    
98      RETURN
99    END SUBROUTINE limx
Legend:
Removed from v.27  
changed lines
  Added in v.157
  ViewVC Help
Powered by ViewVC 1.1.21