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

Diff of /trunk/dyn3d/fluxstokenc.f90

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

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