/[lmdze]/trunk/dyn3d/fluxstokenc.f
ViewVC logotype

Diff of /trunk/dyn3d/fluxstokenc.f

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

revision 30 by guez, Thu Apr 1 09:07:28 2010 UTC revision 68 by guez, Wed Nov 14 16:59:30 2012 UTC
# Line 1  Line 1 
1  SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,time_step,itau)  SUBROUTINE fluxstokenc(pbaru, pbarv, masse, teta, phi, phis, time_step, itau)
2    
3    !     Auteur :  F. Hourdin    ! Author: F. Hourdin
4    
5    USE histwrite_m    USE histwrite_m, ONLY : histwrite
6    USE dimens_m    USE dimens_m, ONLY : jjm, llm, nqmx
7    USE paramet_m    USE paramet_m, ONLY : iip1, ijmllm, ijp1llm, ip1jm, ip1jmp1, jjp1
8    USE comconst    USE comgeom, ONLY : aire
9    USE comvert    USE tracstoke, ONLY : istdyn, istphy
   USE comgeom  
   USE temps  
   USE tracstoke  
10    
11    IMPLICIT NONE    IMPLICIT NONE
12    
13    REAL, intent(in):: time_step    REAL pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
14    real t_wrt, t_ops    REAL masse(ip1jmp1, llm)
15    REAL pbaru(ip1jmp1,llm), pbarv(ip1jm,llm)    real, intent(in):: phi(ip1jmp1, llm)
16    REAL masse(ip1jmp1,llm), teta(ip1jmp1,llm), phi(ip1jmp1,llm)    real, intent(in):: teta(ip1jmp1, llm)
17    REAL phis(ip1jmp1)    REAL phis(ip1jmp1)
18      REAL, intent(in):: time_step
19      INTEGER, INTENT (IN) :: itau
20    
21    REAL pbaruc(ip1jmp1,llm), pbarvc(ip1jm,llm)    ! Variables local to the procedure:
   REAL massem(ip1jmp1,llm), tetac(ip1jmp1,llm), phic(ip1jmp1,llm)  
   
   REAL pbarug(ip1jmp1,llm), pbarvg(iip1,jjm,llm), wg(ip1jmp1,llm)  
22    
23    REAL pbarvst(iip1,jjp1,llm), zistdyn    REAL, SAVE:: pbaruc(ip1jmp1, llm), pbarvc(ip1jm, llm)
24    REAL dtcum    REAL, SAVE:: massem(ip1jmp1, llm)
25      real, SAVE:: tetac(ip1jmp1, llm), phic(ip1jmp1, llm)
26    
27    INTEGER iadvtr, ndex(1)    REAL pbarug(ip1jmp1, llm), pbarvg(iip1, jjm, llm), wg(ip1jmp1, llm)
   INTEGER nscal  
28    REAL tst(1), ist(1), istp(1)    REAL tst(1), ist(1), istp(1)
29    INTEGER ij, l, irec, i, j    INTEGER ij, l
30    INTEGER, INTENT (IN) :: itau    INTEGER, save:: fluxid, fluxvid
31    INTEGER fluxid, fluxvid, fluxdid    integer fluxdid
   
   SAVE iadvtr, massem, pbaruc, pbarvc, irec  
   SAVE phic, tetac  
   LOGICAL first  
   SAVE first  
   DATA first/ .TRUE./  
   DATA iadvtr/0/  
32    
33    !-------------------------------------------------------------    !-------------------------------------------------------------
34    
35    IF (first) THEN    IF (itau == 0) THEN
36       CALL initfluxsto(time_step,istdyn*time_step,istdyn*time_step,nqmx, &       CALL initfluxsto(time_step, istdyn*time_step, istdyn*time_step, nqmx, &
37            fluxid,fluxvid,fluxdid)            fluxid, fluxvid, fluxdid)
38         CALL histwrite(fluxid, 'phis', 1, phis)
39       ndex(1) = 0       CALL histwrite(fluxid, 'aire', 1, aire)
      CALL histwrite(fluxid,'phis',1,phis)  
      CALL histwrite(fluxid,'aire',1,aire)  
   
      ndex(1) = 0  
      nscal = 1  
40       tst(1) = time_step       tst(1) = time_step
41       CALL histwrite(fluxdid,'dtvr',1,tst)       CALL histwrite(fluxdid, 'dtvr', 1, tst)
42       ist(1) = istdyn       ist(1) = istdyn
43       CALL histwrite(fluxdid,'istdyn',1,ist)       CALL histwrite(fluxdid, 'istdyn', 1, ist)
44       istp(1) = istphy       istp(1) = istphy
45       CALL histwrite(fluxdid,'istphy',1,istp)       CALL histwrite(fluxdid, 'istphy', 1, istp)
   
      first = .FALSE.  
   END IF  
46    
47         CALL initial0(ijp1llm, phic)
48    IF (iadvtr==0) THEN       CALL initial0(ijp1llm, tetac)
49       CALL initial0(ijp1llm,phic)       CALL initial0(ijp1llm, pbaruc)
50       CALL initial0(ijp1llm,tetac)       CALL initial0(ijmllm, pbarvc)
      CALL initial0(ijp1llm,pbaruc)  
      CALL initial0(ijmllm,pbarvc)  
51    END IF    END IF
52    
53    !   accumulation des flux de masse horizontaux    !   accumulation des flux de masse horizontaux
54    DO l = 1, llm    DO l = 1, llm
55       DO ij = 1, ip1jmp1       DO ij = 1, ip1jmp1
56          pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)          pbaruc(ij, l) = pbaruc(ij, l) + pbaru(ij, l)
57          tetac(ij,l) = tetac(ij,l) + teta(ij,l)          tetac(ij, l) = tetac(ij, l) + teta(ij, l)
58          phic(ij,l) = phic(ij,l) + phi(ij,l)          phic(ij, l) = phic(ij, l) + phi(ij, l)
59       END DO       END DO
60       DO ij = 1, ip1jm       DO ij = 1, ip1jm
61          pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)          pbarvc(ij, l) = pbarvc(ij, l) + pbarv(ij, l)
62       END DO       END DO
63    END DO    END DO
64    
65    !   selection de la masse instantannee des mailles avant le transport.    !   selection de la masse instantannee des mailles avant le transport.
66    IF (iadvtr==0) THEN    IF (itau == 0) THEN
67       CALL scopy(ip1jmp1*llm,masse,1,massem,1)       CALL scopy(ip1jmp1*llm, masse, 1, massem, 1)
68    END IF    END IF
69    
70    iadvtr = iadvtr + 1    IF (mod(itau + 1, istdyn) == 0) THEN
71         ! on advecte a ce pas de temps
   
   !   Test pour savoir si on advecte a ce pas de temps  
   IF (iadvtr==istdyn) THEN  
72       !    normalisation       !    normalisation
73       DO l = 1, llm       DO l = 1, llm
74          DO ij = 1, ip1jmp1          DO ij = 1, ip1jmp1
75             pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)             pbaruc(ij, l) = pbaruc(ij, l)/float(istdyn)
76             tetac(ij,l) = tetac(ij,l)/float(istdyn)             tetac(ij, l) = tetac(ij, l)/float(istdyn)
77             phic(ij,l) = phic(ij,l)/float(istdyn)             phic(ij, l) = phic(ij, l)/float(istdyn)
78          END DO          END DO
79          DO ij = 1, ip1jm          DO ij = 1, ip1jm
80             pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)             pbarvc(ij, l) = pbarvc(ij, l)/float(istdyn)
81          END DO          END DO
82       END DO       END DO
83    
# Line 109  SUBROUTINE fluxstokenc(pbaru,pbarv,masse Line 85  SUBROUTINE fluxstokenc(pbaru,pbarv,masse
85       !     1. calcul de w       !     1. calcul de w
86       !     2. groupement des mailles pres du pole.       !     2. groupement des mailles pres du pole.
87    
88       CALL groupe(massem,pbaruc,pbarvc,pbarug,pbarvg,wg)       CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)
   
      DO l = 1, llm  
         DO j = 1, jjm  
            DO i = 1, iip1  
               pbarvst(i,j,l) = pbarvg(i,j,l)  
            END DO  
         END DO  
         DO i = 1, iip1  
            pbarvst(i,jjp1,l) = 0.  
         END DO  
      END DO  
   
      iadvtr = 0  
      PRINT *, 'ITAU auqel on stoke les fluxmasses', itau  
89    
90       CALL histwrite(fluxid,'masse',itau,massem)       CALL histwrite(fluxid, 'masse', itau, massem)
91       CALL histwrite(fluxid,'pbaru',itau,pbarug)       CALL histwrite(fluxid, 'pbaru', itau, pbarug)
92       CALL histwrite(fluxvid,'pbarv',itau,pbarvg)       CALL histwrite(fluxvid, 'pbarv', itau, pbarvg)
93       CALL histwrite(fluxid,'w',itau,wg)       CALL histwrite(fluxid, 'w', itau, wg)
94       CALL histwrite(fluxid,'teta',itau,tetac)       CALL histwrite(fluxid, 'teta', itau, tetac)
95       CALL histwrite(fluxid,'phi',itau,phic)       CALL histwrite(fluxid, 'phi', itau, phic)
96    END IF ! if iadvtr.EQ.istdyn                                          END IF                                
97    
98  END SUBROUTINE fluxstokenc  END SUBROUTINE fluxstokenc
Legend:
Removed from v.30  
changed lines
  Added in v.68
  ViewVC Help
Powered by ViewVC 1.1.21