/[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 57 by guez, Mon Jan 30 12:54:02 2012 UTC trunk/Sources/dyn3d/limx.f revision 155 by guez, Wed Jul 8 17:03:45 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 conf_gcm_m  
       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      LOGICAL first
44      SAVE first
45    
46      REAL ssum
47      INTEGER ismax, ismin
48      EXTERNAL ssum, convflu, ismin, ismax
49    
50      DATA first/.TRUE./
51    
52    
53      DO l = 1, llm
54        DO ij = 1, ip1jmp1
55          q(ij, l) = s0(ij, l)/sm(ij, l)
56          dxq(ij, l) = sx(ij, l)/sm(ij, l)
57        END DO
58      END DO
59    
60      ! calcul de la pente a droite et a gauche de la maille
61    
62      DO l = 1, llm
63        DO ij = iip2, ip1jm - 1
64          dxqu(ij) = q(ij+1, l) - q(ij, l)
65        END DO
66        DO ij = iip1 + iip1, ip1jm, iip1
67          dxqu(ij) = dxqu(ij-iim)
68        END DO
69    
70        DO ij = iip2, ip1jm
71          adxqu(ij) = abs(dxqu(ij))
72        END DO
73    
74        ! calcul de la pente maximum dans la maille en valeur absolue
75    
76        DO ij = iip2 + 1, ip1jm
77          dxqmax(ij) = pente_max*min(adxqu(ij-1), adxqu(ij))
78        END DO
79    
80        DO ij = iip1 + iip1, ip1jm, iip1
81          dxqmax(ij-iim) = dxqmax(ij)
82        END DO
83    
84        ! calcul de la pente avec limitation
85    
86        DO ij = iip2 + 1, ip1jm
87          IF (dxqu(ij-1)*dxqu(ij)>0. .AND. dxq(ij,l)*dxqu(ij)>0.) THEN
88            dxq(ij, l) = sign(min(abs(dxq(ij,l)),dxqmax(ij)), dxq(ij,l))
89          ELSE
90            ! extremum local
91            dxq(ij, l) = 0.
92          END IF
93        END DO
94        DO ij = iip1 + iip1, ip1jm, iip1
95          dxq(ij-iim, l) = dxq(ij, l)
96        END DO
97    
98        DO ij = 1, ip1jmp1
99          sx(ij, l) = dxq(ij, l)*sm(ij, l)
100        END DO
101    
102      END DO
103    
104      RETURN
105    END SUBROUTINE limx
Legend:
Removed from v.57  
changed lines
  Added in v.155
  ViewVC Help
Powered by ViewVC 1.1.21