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

Diff of /trunk/Sources/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 32 by guez, Tue Apr 6 17:52:58 2010 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), teta(ip1jmp1, llm), phi(ip1jmp1, llm)
   REAL pbaru(ip1jmp1,llm), pbarv(ip1jm,llm)  
   REAL masse(ip1jmp1,llm), teta(ip1jmp1,llm), phi(ip1jmp1,llm)  
15    REAL phis(ip1jmp1)    REAL phis(ip1jmp1)
16      REAL, intent(in):: time_step
17      INTEGER, INTENT (IN) :: itau
18    
19    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)  
20    
21    REAL pbarvst(iip1,jjp1,llm), zistdyn    REAL, SAVE:: pbaruc(ip1jmp1, llm), pbarvc(ip1jm, llm)
22    REAL dtcum    REAL, SAVE:: massem(ip1jmp1, llm)
23      real, SAVE:: tetac(ip1jmp1, llm), phic(ip1jmp1, llm)
24    
25    INTEGER iadvtr, ndex(1)    REAL pbarug(ip1jmp1, llm), pbarvg(iip1, jjm, llm), wg(ip1jmp1, llm)
   INTEGER nscal  
26    REAL tst(1), ist(1), istp(1)    REAL tst(1), ist(1), istp(1)
27    INTEGER ij, l, irec, i, j    INTEGER ij, l
28    INTEGER, INTENT (IN) :: itau    INTEGER, save:: fluxid, fluxvid
29    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/  
30    
31    !-------------------------------------------------------------    !-------------------------------------------------------------
32    
33    IF (first) THEN    IF (itau == 0) THEN
34       CALL initfluxsto(time_step,istdyn*time_step,istdyn*time_step,nqmx, &       CALL initfluxsto(time_step, istdyn*time_step, istdyn*time_step, nqmx, &
35            fluxid,fluxvid,fluxdid)            fluxid, fluxvid, fluxdid)
36         CALL histwrite(fluxid, 'phis', 1, phis)
37       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  
38       tst(1) = time_step       tst(1) = time_step
39       CALL histwrite(fluxdid,'dtvr',1,tst)       CALL histwrite(fluxdid, 'dtvr', 1, tst)
40       ist(1) = istdyn       ist(1) = istdyn
41       CALL histwrite(fluxdid,'istdyn',1,ist)       CALL histwrite(fluxdid, 'istdyn', 1, ist)
42       istp(1) = istphy       istp(1) = istphy
43       CALL histwrite(fluxdid,'istphy',1,istp)       CALL histwrite(fluxdid, 'istphy', 1, istp)
   
      first = .FALSE.  
   END IF  
44    
45         CALL initial0(ijp1llm, phic)
46    IF (iadvtr==0) THEN       CALL initial0(ijp1llm, tetac)
47       CALL initial0(ijp1llm,phic)       CALL initial0(ijp1llm, pbaruc)
48       CALL initial0(ijp1llm,tetac)       CALL initial0(ijmllm, pbarvc)
      CALL initial0(ijp1llm,pbaruc)  
      CALL initial0(ijmllm,pbarvc)  
49    END IF    END IF
50    
51    !   accumulation des flux de masse horizontaux    !   accumulation des flux de masse horizontaux
52    DO l = 1, llm    DO l = 1, llm
53       DO ij = 1, ip1jmp1       DO ij = 1, ip1jmp1
54          pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)          pbaruc(ij, l) = pbaruc(ij, l) + pbaru(ij, l)
55          tetac(ij,l) = tetac(ij,l) + teta(ij,l)          tetac(ij, l) = tetac(ij, l) + teta(ij, l)
56          phic(ij,l) = phic(ij,l) + phi(ij,l)          phic(ij, l) = phic(ij, l) + phi(ij, l)
57       END DO       END DO
58       DO ij = 1, ip1jm       DO ij = 1, ip1jm
59          pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)          pbarvc(ij, l) = pbarvc(ij, l) + pbarv(ij, l)
60       END DO       END DO
61    END DO    END DO
62    
63    !   selection de la masse instantannee des mailles avant le transport.    !   selection de la masse instantannee des mailles avant le transport.
64    IF (iadvtr==0) THEN    IF (itau == 0) THEN
65       CALL scopy(ip1jmp1*llm,masse,1,massem,1)       CALL scopy(ip1jmp1*llm, masse, 1, massem, 1)
66    END IF    END IF
67    
68    iadvtr = iadvtr + 1    IF (mod(itau + 1, istdyn) == 0) THEN
69         ! on advecte a ce pas de temps
   
   !   Test pour savoir si on advecte a ce pas de temps  
   IF (iadvtr==istdyn) THEN  
70       !    normalisation       !    normalisation
71       DO l = 1, llm       DO l = 1, llm
72          DO ij = 1, ip1jmp1          DO ij = 1, ip1jmp1
73             pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)             pbaruc(ij, l) = pbaruc(ij, l)/float(istdyn)
74             tetac(ij,l) = tetac(ij,l)/float(istdyn)             tetac(ij, l) = tetac(ij, l)/float(istdyn)
75             phic(ij,l) = phic(ij,l)/float(istdyn)             phic(ij, l) = phic(ij, l)/float(istdyn)
76          END DO          END DO
77          DO ij = 1, ip1jm          DO ij = 1, ip1jm
78             pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)             pbarvc(ij, l) = pbarvc(ij, l)/float(istdyn)
79          END DO          END DO
80       END DO       END DO
81    
# Line 109  SUBROUTINE fluxstokenc(pbaru,pbarv,masse Line 83  SUBROUTINE fluxstokenc(pbaru,pbarv,masse
83       !     1. calcul de w       !     1. calcul de w
84       !     2. groupement des mailles pres du pole.       !     2. groupement des mailles pres du pole.
85    
86       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  
87    
88       CALL histwrite(fluxid,'masse',itau,massem)       CALL histwrite(fluxid, 'masse', itau, massem)
89       CALL histwrite(fluxid,'pbaru',itau,pbarug)       CALL histwrite(fluxid, 'pbaru', itau, pbarug)
90       CALL histwrite(fluxvid,'pbarv',itau,pbarvg)       CALL histwrite(fluxvid, 'pbarv', itau, pbarvg)
91       CALL histwrite(fluxid,'w',itau,wg)       CALL histwrite(fluxid, 'w', itau, wg)
92       CALL histwrite(fluxid,'teta',itau,tetac)       CALL histwrite(fluxid, 'teta', itau, tetac)
93       CALL histwrite(fluxid,'phi',itau,phic)       CALL histwrite(fluxid, 'phi', itau, phic)
94    END IF ! if iadvtr.EQ.istdyn                                          END IF                                
95    
96  END SUBROUTINE fluxstokenc  END SUBROUTINE fluxstokenc
Legend:
Removed from v.30  
changed lines
  Added in v.32
  ViewVC Help
Powered by ViewVC 1.1.21